G2dImplicitToolImpl.mesa
Copyright Ó 1985, 1992 by Xerox Corporation. All rights reserved.
Bloomenthal, August 25, 1992 2:24 pm PDT
DIRECTORY CedarProcess, Commander, CommanderOps, Controls, Draw2d, FileNames, G2dBasic, G2dImplicitTool, G2dVector, Icons, Imager, ImagerBackdoor, ImagerSample, IO, Process, Real, RealFns, Rope, VFonts, ViewerClasses, ViewerOps;
G2dImplicitToolImpl: CEDAR PROGRAM
IMPORTS CedarProcess, CommanderOps, Controls, Draw2d, FileNames, G2dBasic, G2dVector, Icons, Imager, IO, Process, Real, RealFns, Rope, VFonts, ViewerOps
EXPORTS G2dImplicitTool
~ BEGIN
Types
ForkableProc: TYPE ~ CedarProcess.ForkableProc;
CommandProc: TYPE ~ Commander.CommandProc;
ButtonList:  TYPE ~ Controls.ButtonList;
ClickProc:  TYPE ~ Controls.ClickProc;
ControlList:  TYPE ~ Controls.ControlList;
Request:   TYPE ~ Controls.Request;
DrawProc:  TYPE ~ Draw2d.DrawProc;
Zip:    TYPE ~ Draw2d.Zip;
IntegerPair:  TYPE ~ G2dBasic.IntegerPair;
Pair:    TYPE ~ G2dBasic.Pair;
PairSequence: TYPE ~ G2dBasic.PairSequence;
StartProc:   TYPE ~ G2dImplicitTool.StartProc;
Tool:    TYPE ~ G2dImplicitTool.Tool;
ValueProc:  TYPE ~ G2dImplicitTool.ValueProc;
Context:   TYPE ~ Imager.Context;
ROPE:    TYPE ~ Rope.ROPE;
Direction:   TYPE ~ {l, t, r, b}; -- clockwise: left, top, right, bottom
Point:    TYPE ~ RECORD [pos: Pair, value: REAL];
Two-Dimensional Function Tool
icon: Icons.IconFlavor ¬ Icons.NewIconFromFile["G2dUser.icons", 8];
MakeTool: PUBLIC PROC [
name:    ROPE,
valueProc:  ValueProc,
extraButtons:  ButtonList ¬ NIL,
extraControls: ControlList ¬ NIL,
clientData:  REF ANY ¬ NIL,
clientDraw:  DrawProc ¬ NIL,
startProc:   StartProc ¬ NIL,
scale:    REAL ¬ 1.0,
move:    Pair ¬ [0.0, 0.0],
toolSettings:  G2dImplicitTool.ToolRep ¬ []]
RETURNS [t: Tool]
~ {
AddButton: PROC [name: ROPE, proc: ClickProc, guarded: BOOL ¬ FALSE] ~ {
extraButtons ¬ CONS[Controls.ClickButton[name, proc, t,,,,,,, guarded], extraButtons];
};
t ¬ NEW[G2dImplicitTool.ToolRep ¬ toolSettings];
AddButton["IO", IOButton];
AddButton["Display", DisplayButton];
AddButton["Curve", CurveButton];
AddButton["STOP", StopButton, TRUE];
AddButton["Animation", AnimationButton];
extraControls ¬ CONS[t.scale ¬ Controls.NewControl["Scale",, t, 0, 2, scale, Cam], extraControls];
extraControls ¬ CONS[t.moveX ¬Controls.NewControl["X",, t, -2, 2, move.x, Cam], extraControls];
extraControls ¬ CONS[t.moveY ¬Controls.NewControl["Y",, t, -2, 2, move.y, Cam], extraControls];
t.startProc ¬ startProc;
t.valueProc ¬ valueProc;
t.clientDraw ¬ clientDraw;
t.clientData ¬ clientData;
t.buttons ¬ extraButtons;
t.outerData ¬ Controls.OuterViewer[
name: name,
buttons: extraButtons,
controls: extraControls,
typescriptHeight: 18,
graphicsHeight: 300,
destroyProc: Destroy,
drawProc: Draw,
noOpen: TRUE,
icon: icon,
clientData: t];
t.graphics ¬ t.outerData.graphics;
t.outerData.parent.label ¬ name;
t.typescript ¬ t.outerData.typescript;
[] ¬ CedarProcess.Fork[OpenViewer, t]; -- don't ask client to draw till after tool returned
};
Cam: Controls.ControlProc ~ {Repaint[NARROW[clientData]]};
OpenViewer: ForkableProc ~ {
t: Tool ¬ NARROW[data];
Process.PauseMsec[500]; -- should be plenty
ViewerOps.OpenIcon[t.outerData.parent];
};
Destroy: Controls.DestroyProc ~ {CedarProcess.Abort[NARROW[clientData, Tool].process]};
ToolBusy: PUBLIC PROC [tool: Tool] RETURNS [BOOL] ~ {
RETURN[tool.process # NIL AND CedarProcess.GetStatus[tool.process] = busy];
};
MaybeFork: PUBLIC PROC [tool: Tool, proc: ForkableProc] RETURNS [forked: BOOL] ~ {
IF (forked ¬ NOT ToolBusy[tool])
THEN tool.process ¬ CedarProcess.Fork[proc, tool, [background, TRUE]]
ELSE TSWrite[tool, "Tool is busy!\n"];
};
Stop: PUBLIC PROC [tool: Tool, reason: ROPE ¬ NIL, waitTilAborted: BOOL ¬ FALSE] ~ {
IF tool.process = NIL OR tool.process.abortRequested THEN RETURN;
CedarProcess.Abort[tool.process];
IF waitTilAborted THEN [] ¬ CedarProcess.Join[tool.process];
IF reason # NIL THEN TSWrite[tool, reason];
};
StopButton: ClickProc ~ {Stop[NARROW[clientData], " . . . aborted\n"]};
Animation
AnimationButton: ClickProc ~ {
t: Tool ¬ NARROW[clientData];
SELECT Controls.PopUpRequest[["Animation Options"], LIST[
--1 --  IntRequest["First Frame", "First frame of animation", t.firstFrame],
--2 --  IntRequest["Last Frame", "Last frame of animation", t.lastFrame],
--3 -- IntRequest["Current Frame", "Current frame in the animation", t.currentFrame],
--4 -- RopeRequest["Ouptut IP name", "Base for Interpress files", t.animateIP],
--5 -- ["ANIMATE Curve", "Create frame from current through last"]]] FROM
1 =>   t.firstFrame ¬ Controls.GetNat[t.typescript, "first frame", t.firstFrame];
2 =>   t.lastFrame ¬ Controls.GetNat[t.typescript, "last frame", t.lastFrame];
3 =>   t.currentFrame ¬ Controls.GetNat[t.typescript, "current frame", t.currentFrame];
4 =>   t.animateIP ¬ Controls.TypescriptReadFileName[t.typescript];
5 =>  [] ¬ MaybeFork[t, ForkAnimateCurve];
ENDCASE;
};
ForkAnimateCurve: ForkableProc ~ {
t: Tool ¬ NARROW[data];
FOR i: NAT IN [t.currentFrame..t.lastFrame] DO
IF t.animateIP # NIL THEN t.saveIP ¬ IO.PutFR["%g.%g.ip", IO.rope[t.animateIP], IO.int[i]];
t.currentFrame ¬ i;
MakeCurve[t];
ENDLOOP;
};
Display
Repaint: PUBLIC PROC [tool: Tool, whatChanged: REF ANY ¬ NIL] ~ {
ViewerOps.PaintViewer[tool.graphics, client, FALSE, whatChanged];
};
Draw: DrawProc ~ {
Action: PROC ~ {
DrawClient: PROC ~ {
IF t.clientDraw # NIL AND t.displayClient
THEN t.clientDraw[context, t.clientData, whatChanged, viewer];
};
DrawCurve: PROC ~ {
IF t.curve # NIL THEN {
p0: Pair ¬ t.curve[0];
FOR n: NAT IN [1..t.curve.length) DO
p1: Pair ¬ t.curve[n];
Draw2d.Line[context, p0, p1,, t.zip];
p0 ¬ p1;
ENDLOOP;
};
};
Imager.TranslateT[context, [t.moveX.value+0.5*viewer.cw, t.moveY.value+0.5*viewer.ch]];
Imager.ScaleT[context, t.scale.value*0.5*MIN[viewer.cw, viewer.ch]];
t.zip ¬ Draw2d.GetZip[context];
SELECT whatChanged FROM
$Clear => Draw2d.Clear[context];
$Client => DrawClient[];
$Point => Draw2d.Line[context, t.curve[t.curve.length-2], t.curve[t.curve.length-1],,t.zip];
ENDCASE => {Draw2d.Clear[context]; DrawCurve[]; DrawClient[]};
Draw2d.ReleaseZip[t.zip];
};
t: Tool ¬ NARROW[clientData];
IF whatChanged = $Client
THEN Draw2d.DoWithBuffer[context, Action, t.displayClient]
ELSE Action[];
};
DisplayButton: ClickProc ~ {
t: Tool ¬ NARROW[clientData];
SELECT Controls.PopUpRequest[["Display"], LIST[
--1-- Controls.BoolRequest[t.displayClient, "Display Client"]]] FROM
1 => t.displayClient ¬ NOT t.displayClient;
ENDCASE => RETURN;
IF Controls.GetPopUpButton[] = right THEN Repaint[t, $Client];
};
Curve Operations
CurveButton: ClickProc ~ {
RealRequest: PROC [title, doc: ROPE, value: REAL] RETURNS [Request] ~ {
RETURN[[IO.PutFR["%g (now %6.3f)", IO.rope[title], IO.real[value]], doc]];
};
t: Tool ¬ NARROW[clientData];
SELECT Controls.PopUpRequest[["Quadtree Options"], LIST[
--1-- RealRequest["tracking size", "Square size for tracking curve", t.size],
--2-- RealRequest["threshold", "Contour level", t.threshold],
--3-- ["MAKE CURVE", "Create the contour curve"]]] FROM
1 => t.size ¬ Controls.GetReal[t.typescript, "track size", t.size];
2 => t.threshold ¬ Controls.GetReal[t.typescript, "threshold", t.threshold];
3 => [] ¬ MaybeFork[t, ForkMakeCurve];
ENDCASE;
};
ForkMakeCurve: ForkableProc ~ {MakeCurve[NARROW[data]]};
MakeCurve: PROC [t: Tool] ~ {
Cross: PROC [p0, p1: Point] RETURNS [b: BOOL] ~ {b ¬ (p0.value < 0.0) # (p1.value <= 0.0)};
DoPoint: PROC [p: Point, d: Direction] RETURNS [Point] ~ {
pos: Pair ¬ SELECT d FROM
l => [p.pos.x-t.size, p.pos.y],
t => [p.pos.x, p.pos.y-t.size],
r => [p.pos.x+t.size, p.pos.y],
ENDCASE => [p.pos.x, p.pos.y+t.size];
RETURN[[pos, t.valueProc[pos, t.clientData]-t.threshold]];
};
NewVertex: PROC [in, out: Point] ~ {
t.curve ¬ G2dBasic.AddToPairSequence[t.curve,
Converge[in, out, t.valueProc, t.threshold, t.clientData]];
IF t.curve.length > 1 THEN Repaint[t, $Point];
};
Process: PROC [p0, p1: Point, d: Direction] ~ {
id: IntegerPair ¬ [0, 0];
DO
CedarProcess.CheckAbort[];
NewVertex[p0, p1];
d ¬ SELECT d FROM l => b, t => l, r => t, ENDCASE => r;
DO
p1 ¬ DoPoint[p0, d];
IF Cross[p0, p1] THEN EXIT;
p0 ¬ p1;
d ¬ SELECT d FROM l => t, t => r, r => b, ENDCASE => l;
ENDLOOP;
id ¬ SELECT d FROM
l => [id.x-1, id.y], t => [id.x, id.y-1], r => [id.x+1, id.y], ENDCASE => [id.x, id.y+1];
IF id = [0, 0] THEN {NewVertex[p0, p1]; EXIT};
ENDLOOP;
};
start: Pair ¬ FindStart[t.valueProc, t.threshold, t.clientData ! FindError => GOTO Bad];
p: Pair ¬ [t.size*REAL[Real.Round[start.x/t.size]], t.size*REAL[Real.Round[start.y/t.size]]];
lt: Point ¬ [p, t.valueProc[p, t.clientData]-t.threshold];
rt: Point ¬ DoPoint[lt, r];
rb: Point ¬ DoPoint[rt, b];
lb: Point ¬ DoPoint[rb, l];
IF t.curve # NIL THEN t.curve.length ¬ 0;
Repaint[t, $Clear];
IF Cross[rt, lt] THEN Process[lt, rt, r] ELSE
IF Cross[rb, rt] THEN Process[rt, rb, b] ELSE
IF Cross[lb, rb] THEN Process[rb, lb, l] ELSE
IF Cross[lt, lb] THEN Process[lb, lt, t];
EXITS Bad => TSWrite[t, "Can't find starting point"];
};
FindError: ERROR = CODE;
FindStart: PROC [value: ValueProc, threshold: REAL, clientData: REF ANY] RETURNS [Pair] ~ {
Find: PROC [sign: {neg, pos}] RETURNS [p: Point] ~ {
d, v: REAL ¬ 0.1;
THROUGH [0..20) DO
FOR alpha: REAL ¬ 0.0, alpha+30.0 WHILE alpha <= 360.0 DO
p.pos ¬ [d*RealFns.CosDeg[alpha], d*RealFns.SinDeg[alpha]];
p.value ¬ value[p.pos, clientData]-threshold;
IF (sign = neg AND p.value <= 0.0) OR (sign = pos AND p.value >= 0.0) THEN RETURN;
ENDLOOP;
d ¬ d+d;
ENDLOOP;
ERROR FindError;
};
RETURN[Converge[Find[pos], Find[neg], value, threshold, clientData]];
};
Converge: PROC [in, out: Point, value: ValueProc, threshold: REAL, clientData: REF ANY]
RETURNS [p: Pair]
~ {
Inner: PROC [in, out: Point, nTries: NAT ¬ 0] RETURNS [p: Pair] ~ {
v, dAbs: REAL ¬ ABS[G2dVector.Distance[in.pos, out.pos]];
p ¬ G2dVector.Midpoint[in.pos, out.pos];
IF nTries = 0 THEN epsilon ¬ 0.001*dAbs;
IF dAbs < epsilon OR (nTries ¬ nTries+1) > 10 THEN RETURN;
RETURN[IF (v ¬ value[p, clientData]-threshold) < 0.0
THEN Inner[in, [p, v], nTries]
ELSE Inner[[p, v], out, nTries]];
};
epsilon: REAL;
IF in.value < 0.0 THEN {pt: Point ¬ in; in ¬ out; out ¬ pt};
p ¬ SELECT TRUE FROM in.value=0=> in.pos, out.value=0=> out.pos, ENDCASE => Inner[in, out];
};
IO
IOButton: ClickProc ~ {
t: Tool ¬ NARROW[clientData];
Inner: PROC ~ {
SELECT Controls.PopUpRequest[["Output"], LIST[
--1-- ["OUTPUT INTERPRESS", "Output interpress file of the current display"],
--2-- ["IP stroke width", "width of strokes for IP output"]]] FROM
1 => Draw2d.IPOut[Controls.TypescriptReadFileName[t.typescript], Draw, t];
2 => t.ipStrokeWidth ¬ Controls.GetReal[t.typescript, "Stroke width", t.ipStrokeWidth];
ENDCASE;
};
CedarProcess.DoWithPriority[background, Inner];
};
Support
RopeRequest: PROC [title, doc, value: ROPE] RETURNS [req: Request] ~ {
req ¬ IF value = NIL
THEN [IO.PutFR1["%g", IO.rope[title]], doc]
ELSE [IO.PutFR["%g (now %g)", IO.rope[title], IO.rope[value]], doc];
};
IntRequest: PROC [title, doc: ROPE, value: NAT] RETURNS [Request] ~ {
RETURN[[IO.PutFR["%g (now %g)", IO.rope[title], IO.int[value]], doc]];
};
Eq: PROC [r1, r2: ROPE] RETURNS [b: BOOL] ~ {b ¬ Rope.Equal[r1, r2, FALSE]};
TSWrite: PROC [t: Tool, rope: ROPE] ~ {Controls.TypescriptWrite[t.typescript, rope]};
Registration and Dispatching
Registration: TYPE ~ RECORD [
name:     ROPE,         -- name of implicit function
command:   CommandProc,      -- proc to be called
doc:     ROPE         -- documentation of function
];
registry:  LIST OF Registration ¬ NIL;
Register: PUBLIC PROC [name: ROPE, command: CommandProc, doc: ROPE] ~ {
IF registry = NIL
THEN registry ¬ LIST[[name, command, doc]]
ELSE FOR l: LIST OF Registration ¬ registry, l.rest WHILE l # NIL DO
IF Eq[l.first.name, name] THEN {l.first ¬ [name, command, doc]; EXIT};
IF l.rest = NIL THEN {l.rest ¬ LIST[[name, command, doc]]; EXIT};
ENDLOOP;
};
ToolOptions: PUBLIC PROC RETURNS [toolOptions: ROPE ¬ NIL] ~ {
tabWidth: INT ¬ 2*VFonts.StringWidth["\t"];  -- VFonts says 12; but should be 24
FOR l: LIST OF Registration ¬ registry, l.rest WHILE l # NIL DO
colonTabs: ROPE ¬ ":";
nTabs: INT ¬ 2+MAX[81-VFonts.StringWidth[Rope.Concat[l.first.name, ":"]], 0]/tabWidth;
THROUGH [1..nTabs] DO colonTabs ¬ Rope.Concat[colonTabs, "\t"]; ENDLOOP;
toolOptions ¬ Rope.Cat[toolOptions, "\n\t", l.first.name, colonTabs, l.first.doc];
ENDLOOP;
};
ExecuteOption: PUBLIC CommandProc ~ {
argv: CommanderOps.ArgumentVector ¬ CommanderOps.Parse[cmd];
IF argv.argc > 1 THEN SELECT TRUE FROM
Eq[argv[1], "reset"] => registry ¬ NIL;
ENDCASE => {
FOR l: LIST OF Registration ¬ registry, l.rest WHILE l # NIL DO
IF Eq[l.first.name, argv[1]] THEN {
[result, msg] ¬ l.first.command[cmd];
RETURN;
};
ENDLOOP;
RETURN[$Failure, "No such option."];
};
};
DesignCmd: PUBLIC CommandProc ~ {
argv: CommanderOps.ArgumentVector ¬ CommanderOps.Parse[cmd];
name: ROPE ¬ FileNames.GetShortName[cmd.command]; -- proc may be registered elsewhere
IF argv.argc < 2 THEN RETURN[$Failure, Rope.Concat[name, " <option | ?>"]];
IF Eq[argv[1], "?"]
THEN RETURN[$Failure, Rope.Cat[name, " <option>, options include:", ToolOptions[]]]
ELSE [result, msg] ¬ ExecuteOption[cmd];
};
END.
..
Connected Version of Above (cf ImplicitDesignImpl.mesa)
NatSequence:   TYPE ~ G2dBasic.NatSequence;
Corner:    TYPE ~ G2dQuadtree.Corner;
Square:    TYPE ~ G2dQuadtree.Square;
SquareProc:   TYPE ~ G2dQuadtree.SquareProc;
Quadtree:    TYPE ~ G2dQuadtree.Quadtree;
QuadtreeRep:   TYPE ~ G2dQuadtree.QuadtreeRep;
Quadrant:    TYPE ~ G2dQuadtree.Quadrant;
TwoCorners:   TYPE ~ G2dQuadtree.TwoCorners;
TwoQuadrants:  TYPE ~ G2dQuadtree.TwoQuadrants;
Cross:     TYPE ~ G2dQuadtree.Cross;
Edge:     TYPE ~ G2dQuadtree.Edge;
Stack:     TYPE ~ G2dQuadtree.Stack;
CrossedEdge:   TYPE ~ RECORD [       -- a surface-crossedEdge edge
cIn, cOut:     Corner ¬ NIL,     -- inside and outside corners
qIn, qOut:     Quadrant       -- and their octants
];
CrossedEdges:  TYPE ~ ARRAY Edge OF CrossedEdge; -- possible edge-surface intersections
Display
Repaint: PUBLIC PROC [t: Tool, whatChanged: REF ANY ¬ NIL] ~ {
ViewerOps.PaintViewer[t.outer, client, FALSE, whatChanged];
};
DrawSurface: PROC [context: Context, t: Tool, zip: Draw2d.Zip] ~ {
IF t = NIL OR t.polygons = NIL THEN RETURN;
SetScreens[t];
FOR n: NAT IN [0..t.polygons.length) DO
poly: NatSequence ¬ t.polygons[n];
p0: Pair ¬ t.screens[poly[poly.length-1]];
FOR nn: NAT IN [0..poly.length) DO
p1: Pair ¬ t.screens[poly[nn]];
Draw2d.Line[context, p0, p1, solid, zip];
p0 ¬ p1;
ENDLOOP;
ENDLOOP;
};
TransformPair: PROC [t: Tool, p: Pair] RETURNS [x: Pair] ~ {
x ¬ [p.x*t.scale.value+t.moveX.value, p.y*t.scale.value+t.moveY.value];
};
SetScreens: PUBLIC PROC [t: Tool] ~ {
IF t # NIL AND t.vertices # NIL THEN {
IF t.screens = NIL OR t.screens.maxLength < t.vertices.length
THEN t.screens ¬ NEW[G3dBasic.PairSequenceRep[t.vertices.length]];
FOR n: NAT IN [0..t.vertices.length) DO
t.screens[n] ¬ TransformPair[t, t.vertices[n]];
ENDLOOP;
};
};
Draw: DrawProc ~ {
DrawSquare: PROC [square: Square] ~ {
p0: Pair ¬ TransformPair[t, square.corners[Quadrant.LAST].point];
FOR q: Quadrant IN Quadrant DO
p1: Pair ¬ TransformPair[t, square.corners[q].point];
Draw2d.Line[context, p0, p1, solid, zip];
p0 ¬ p1;
ENDLOOP;
};
DrawPolygon: PROC [poly: NatSequence] ~ {
p0: Pair ¬ TransformPair[t, t.vertices[poly[poly.length-1]]];
FOR n: NAT IN [0..poly.length) DO
p1: Pair ¬ TransformPair[t, t.vertices[poly[n]]];
Draw2d.Line[context, p0, p1, solid, zip];
p0 ¬ p1;
ENDLOOP;
};
DrawClient: PROC ~ {
IF t.clientDraw # NIL THEN t.clientDraw[context, t.clientData, whatChanged, viewer];
};
t: Tool ¬ NARROW[data];
zip: Zip ¬ Draw2d.GetZip[context];
SELECT whatChanged FROM
NIL, $IPOut, $Camera => {DrawSurface[context, t, zip]; DrawClient[]};
$Clear => Draw2d.Clear[context];
$Client => {Draw2d.Clear[context]; DrawClient[]};
$MakeQuadtree => DrawSquare[NARROW[t.progress]];
$MakePolygons => DrawPolygon[NARROW[t.progress]];
$MakeVertices => Draw2d.Mark[context, NARROW[t.progress, REF Pair]­, x];
ENDCASE;
Draw2d.ReleaseZip[zip];
};
Surface Operations
QuadtreeButton: ClickProc ~ {
V: PROC [title, doc: ROPE, value: REAL] RETURNS [Request] ~ RealRequest;
t: Tool ¬ NARROW[clientData];
choice: INT ¬ Controls.PopUpRequest[["Quadtree Options"], LIST[
--1-- ["set measure mode", "Choose a measure mode (default is segment)"],
--2-- V["tracking size", "Square size for tracking surface", t.trackSize],
--3-- ["DO IT", "Make and polygonize an quadtree"]]];
SELECT choice FROM
1 => SetMeasureMode[t];
2 => t.trackSize ¬ GetReal[t, "TrackSize", t.trackSize];
3 => [] ¬ MaybeFork[t, ForkMakeAll];
ENDCASE;
};
SetMeasureMode: PROC [t: Tool] ~ {
r: ROPE ¬ Atom.GetPName[t.measureMode];
r ¬ Controls.TypescriptRead[t.typescript, Rope.Cat["Specify Measure Mode (now ", r, "): "]];
IF NOT Rope.IsEmpty[r] THEN {
c: CHAR ¬ Rope.Fetch[r];
r ¬ Rope.Concat[Rope.FromChar[IF c IN ['a..'z] THEN c-'a+'A ELSE c], Rope.Substr[r, 1]];
t.measureMode ¬ Atom.MakeAtom[r];
};
};
NoSurfacePoint, NoCrossedEdge, Abort, ValueNotSet: ERROR = CODE;
ForkMakeAll: ForkableProc ~ {DoAll[NARROW[data]]};
DoAll: PROC [t: Tool] ~ {
ENABLE NoSurfacePoint => GOTO NoStart;
Status: StatusProc ~ {
WITH ref SELECT FROM
c: Square => {t.progress ¬ c; Repaint[t, surfaceState]};
a: ATOM => IF (surfaceState ¬ a) = $MakePolygons THEN SetScreens[t];
r: ROPE => TSWrite[t, r];
ENDCASE;
CedarProcess.CheckAbort[];
IF CedarProcess.GetStatus[t.process] = aborted THEN RETURN[$Abort];
};
surfaceState: ATOM ¬ $Nothing;
Repaint[t];
IF t.startProc # NIL THEN t.startProc[t.clientData, t.currentFrame, t.lastFrame-t.firstFrame+1];
t.quadtree ¬ MakeQuadtree[t.valueProc, t.trackSize, t.threshold, Status, t.clientData];
MakePolygons[t, Status];
Repaint[t];
EXITS NoStart => Controls.TypescriptWrite[t.typescript, "Can't find a starting point\n"];
};
SetCornerValues: PROC [s: Square, value: ValueProc, threshold: REAL, clientData: REF ANY] ~ {
FOR q: Quadrant IN Quadrant DO
c: Corner ~ s.corners[q];
IF NOT c.valueSet THEN {
c.value ¬ value[c.point, clientData]-threshold;
c.valueSet ¬ TRUE;
c.inside ¬ c.value > 0.0;
};
ENDLOOP;
};
GetCrossedEdges: PROC [s: Square] RETURNS [ce: CrossedEdges] ~ {
Test: PROC [e: Edge] ~ {
Inner: PROC [q0, q1: Quadrant] ~ {
c0: Corner ~ s.corners[q0];
c1: Corner ~ s.corners[q1];
IF c0.inside
THEN {IF NOT c1.inside THEN ce[e] ¬ [c0, c1, q0, q1]}
ELSE {IF c1.inside THEN ce[e] ¬ [c1, c0, q1, q0]};
};
quadrants: TwoQuadrants ~ G2dQuadtree.EdgeQuadrants[e];
Inner[quadrants.q0, quadrants.q1];
};
FOR e: Edge IN Edge DO Test[e]; ENDLOOP;
};
CrossedEdgeCorners: PROC [s: Square] RETURNS [corners: TwoCorners] ~ {
FOR e: Edge IN Edge DO
corners ¬ G2dQuadtree.EdgeCorners[s, e];
IF corners.c0.inside # corners.c1.inside THEN RETURN;
ENDLOOP;
ERROR NoCrossedEdge;
};
SetCrosses: PROC [s: Square, value: ValueProc, threshold: REAL, clientData: REF] ~ {
ce: CrossedEdges ¬ GetCrossedEdges[s];
FOR edge: Edge IN Edge DO
SetCrossedPoint: PROC [ce: CrossedEdge] ~ {
NewCross: PROC RETURNS [cross: Cross] ~ {
p: Pair ~ SegmentConverge[ce.cIn.point, ce.cOut.point, value, threshold, clientData];
cross ¬ NEW[G2dQuadtree.CrossRep ¬ [point: p, value: value[p, clientData]]];
};
direction: Edge ~ G2dQuadtree.DirectionFromQuadrants[ce.qIn, ce.qOut];
c: Corner ~ SELECT direction FROM l, b => ce.cIn, ENDCASE => ce.cOut;
SELECT direction FROM
l, r => IF c.lCross = NIL THEN c.lCross ¬ NewCross[];
b, t => IF c.bCross = NIL THEN c.bCross ¬ NewCross[];
ENDCASE => ERROR;
};
IF ce[edge].cIn # NIL THEN SetCrossedPoint[ce[edge]];
ENDLOOP;
};
MakePolygons: PROC [t: Tool, status: StatusProc ¬ NIL] ~ {
ENABLE Abort => CONTINUE;
CheckStatus: PROC [type: ATOM, commatize: BOOL ¬ FALSE] ~ {
IF status = NIL THEN RETURN;
IF status[type] = $Abort THEN ERROR Abort;
IF NOT Rope.IsEmpty[msg] AND commatize THEN msg ¬ Rope.Concat[", ", msg];
IF NOT Rope.IsEmpty[msg] AND status[msg] = $Abort THEN ERROR Abort;
};
TerminalSquareProc: SquareProc ~ {
IF status # NIL AND status[s] = $Abort THEN ERROR Abort;
SetCornerValues[s, t.valueProc, t.threshold, t.clientData];
SetCrosses[s, t.valueProc, t.threshold, t.clientData];
};
msg: ROPE;
IF t.quadtree = NIL THEN RETURN;
CheckStatus[$SetCorners, TRUE];
G2dQuadtree.ApplyToTerminal[t.quadtree.root, TerminalSquareProc];
CheckStatus[$MakeVertices];
SetVertices[t];
msg ¬ IO.PutFR["%g%g vertices", IO.rope[msg], IO.int[t.vertices.length]];
CheckStatus[$MakePolygons];
msg ¬ SetSurfacePolygons[t];
CheckStatus[$Done];
};
SetSurfacePolygons: PROC [t: Tool] RETURNS [message: ROPE] ~ {
CrossPolygonize: SquareProc ~ {
IF IsCrossed[s] THEN {
NextCrossedEdge: PROC [edge: Edge] RETURNS [Edge] ~ {
DO
IF ce[edge ¬ G2dQuadtree.NextCWEdge[edge]].cIn # NIL THEN EXIT;
ENDLOOP;
poly ¬ G2dBasic.AddToNatSequence[poly, CrossFromCrossedEdge[ce[edge]].id];
RETURN[edge];
};
poly: NatSequence;
done: ARRAY Edge OF BOOL ¬ ALL[FALSE];
ce: CrossedEdges ~ GetCrossedEdges[s];
FOR edge: Edge IN Edge DO
IF ce[edge].cIn # NIL AND NOT done[edge] THEN {
e, start: Edge ¬ edge;
poly ¬ NEW[G3dBasic.NatSequenceRep[3]];
DO
e ¬ NextCrossedEdge[e];
done[e] ¬ TRUE;
IF e = start THEN EXIT;
ENDLOOP;
t.polygons ¬ G3dBasic.AddToNatTable[t.polygons, poly];
};
ENDLOOP;
};
};
t.polygons ¬ NEW[G3dBasic.NatTableRep[t.vertices.length]];
G2dQuadtree.ApplyToTerminal[t.quadtree.root, CrossPolygonize];
message ¬ IO.PutFR["%g%g polygons", IO.rope[message], IO.int[t.polygons.length]];
};
IsCrossed: PROC [s: Square] RETURNS [BOOL] ~ {
c: Corner ¬ s.corners[lb];
inside: BOOL ¬ c.inside;
IF NOT c.valueSet THEN ERROR ValueNotSet;
FOR q: Quadrant IN [SUCC[Quadrant.FIRST]..Quadrant.LAST] DO
IF s.corners[q].inside # inside THEN RETURN[TRUE];
ENDLOOP;
RETURN[FALSE];
};
SetVertices: PROC [t: Tool] ~ {
TerminalProc: SquareProc ~ {
AddVertex: PROC [c: Cross] RETURNS [vertexId: INT] ~ {
vertexId ¬ IF t.vertices # NIL THEN t.vertices.length ELSE 0;
t.vertices ¬ G2dBasic.AddToPairSequence[t.vertices, c.point];
refPair­ ¬ c.point;
Repaint[t, $MakeVertices];
};
FOR q: Quadrant IN Quadrant DO
c: Corner ~ s.corners[q];
IF c.lCross # NIL AND c.lCross.id = -1 THEN c.lCross.id ¬ AddVertex[c.lCross];
IF c.bCross # NIL AND c.bCross.id = -1 THEN c.bCross.id ¬ AddVertex[c.bCross];
ENDLOOP;
};
refPair: REF Pair ¬ t.progress ¬ NEW[Pair];
G2dQuadtree.ApplyToTerminal[t.quadtree.root, TerminalProc];
};
MakeQuadtree: PROC [
value: ValueProc,
size: REAL,
threshold: REAL,
status: StatusProc,
clientData: REF ANY ¬ NIL]
RETURNS [q: Quadtree]
~ {
ENABLE Abort => CONTINUE;
ActiveEdges: TYPE ~ ARRAY Edge OF BOOL ¬ ALL[FALSE];
CheckStatus: PROC [r: REF] ~ {IF status # NIL AND status[r] = $Abort THEN ERROR Abort};
GetActiveEdges: PROC [s: Square] RETURNS [activeEdges: ActiveEdges] ~ {
SetCornerValues[s, value, threshold, clientData];
FOR e: Edge IN Edge DO
corners: TwoCorners ¬ G2dQuadtree.EdgeCorners[s, e];
IF corners.c0.inside # corners.c1.inside THEN activeEdges[e] ¬ TRUE;
ENDLOOP;
};
ProcessTopOfStack: PROC [stack: Stack] ~ {
new: Square;
s: Square ¬ G2dQuadtree.ReadTopOfStack[stack];
activeEdges: ActiveEdges ~ GetActiveEdges[s];
FOR e: Edge IN Edge DO
IF activeEdges[e] AND G2dQuadtree.EdgeNeighbor[s, e] = NIL THEN {
q.root ¬ G2dQuadtree.AddSquare[s, e];
q.nSquares ¬ q.nSquares+1;
IF NOT (new ¬ G2dQuadtree.EdgeNeighbor[s, e]).terminal THEN ERROR;
G2dQuadtree.WriteBottomOfStack[new, stack];
CheckStatus[new];
};
ENDLOOP;
};
startPt: Pair ¬ FindStart[value, threshold, clientData];
stack: Stack ¬ G2dQuadtree.NewStack[20000];
CheckStatus[$MakeQuadtree];
q ¬ NEW[QuadtreeRep ¬ [root: G2dQuadtree.NewSquare[size, startPt]]];
G2dQuadtree.WriteBottomOfStack[q.root, stack];
CheckStatus[q.root];
WHILE NOT G2dQuadtree.StackEmpty[stack] DO ProcessTopOfStack[stack]; ENDLOOP;
CheckStatus[IO.PutFR["%g squares", IO.int[G2dQuadtree.NTerminalSquares[q.root]]]];
};
FindStart: PROC [value: ValueProc, threshold: REAL, clientData: REF ANY] RETURNS [p: Pair]
~ {
Find: PROC [sign: {negative, positive}] RETURNS [p: Pair] ~ {
d, v: REAL ¬ 0.1;
THROUGH [0..5) DO
FOR alpha: REAL ¬ 0.0, alpha+30.0 WHILE alpha <= 360.0 DO
p.x ¬ d*RealFns.CosDeg[alpha];
p.y ¬ d*RealFns.SinDeg[alpha];
v ¬ value[p, clientData]-threshold;
IF sign = negative AND v <= 0.0 THEN RETURN;
IF sign = positive AND v >= 0.0 THEN RETURN;
ENDLOOP;
d ¬ d+d;
ENDLOOP;
};
p ¬ SegmentConverge[Find[positive], Find[negative], value, threshold, clientData];
};
SegmentConverge: PROC [
pIn, pOut: Pair,
value: ValueProc,
threshold: REAL ¬ 1.0,
clientData: REF ANY ¬ NIL]
RETURNS [Pair]
~ {
Inner: PROC [pIn, pOut: Pair, vIn, vOut: REAL] RETURNS [point: Pair] ~ {
d, v: REAL ¬ 0.5;
dAbs: REAL ¬ ABS[d ¬ G2dVector.Distance[pIn, pOut]];
point ¬ G2dVector.Midpoint[pIn, pOut];
IF nTries = 0 THEN epsilon ¬ dAbs*0.001;
IF dAbs < epsilon OR (nTries ¬ nTries+1) > 10 THEN RETURN;
RETURN[IF (v ¬ value[point, clientData]-threshold) < 0.0
THEN Inner[pIn, point, vIn, v]
ELSE Inner[point, pOut, v, vOut]];
};
epsilon: REAL;
nTries: NAT ¬ 0;
vIn: REAL ¬ value[pIn, clientData]-threshold;
vOut: REAL ¬ value[pOut, clientData]-threshold;
IF vIn*vOut >= 0.0 THEN ERROR NoSurfacePoint;
RETURN[Inner[pIn, pOut, vIn, vOut]];
};