JunoTop.mesa

Coded May 1981 by Greg Nelson
Converted to use the Viewers window package by Donna Auguste
Last Edited by: Gnelson, January 17, 1984 11:32 am
Last Edited by: Maureen Stone January 19, 1984 12:08 pm
Merged with JunoGerm.mesa by Jorge Stolfi May 19, 1984 4:12:07 am PDT
Last Edited by: Jorge Stolfi June 7, 1984 4:33:49 pm PDT

This is the top level of an experimental interactive graphics program that allows a user to specify the positions of points by declaring geometrical contraints that the positions are to satisfy. The program solves constraints (which can be viewed as simultaneous polynomial equations) by an n-dimensional version of Newton's method for finding the root of a differentiable function.

JunoTop is the exclusive owner of the image viewer (and its associated bitmap). It handles those through the JunoGraphics interface. -- April 11, 1984 7:34:16 pm PST

JunoTop is also the exclusive owner of the internal data structure representing the current image (that is, the points, constraints and actions moused in by the user). It handles those through the JunoImage interface. -- April 11, 1984 7:39:30 pm PST

JunoTop is also the only module that removes stuff from the user event queue. Things are placed there by (a) the cursor menu module, (b) the image viewer NotifyProc (see JunoGraphicsImpl), and (c) by the JunoButtons module. -- April 11, 1984 7:38:55 pm PST

TO FIX:

Error recovery: Check it out

JunoImage.BaloonSelect: should restore point list on UNWIND.

JunoAlgebra.Eval: graphics state-pushing ops (paint, width, etc) should restore graphics state on UNWIND

DIRECTORY

JunoImage,
JunoMatrix USING [Matrix, MapCoords, ComputeTransform],
JunoBody USING [MakeBody],
JunoOldSolver USING [Outcome],
JunoStorage,
JunoAlgebra USING [Se, Value, comma, lambda, Call],
JunoGraphics USING [Hilyte, DrawChar, DrawPoint, PointSymbol,
DrawRope, SetPaperContext, SetScreenContext, DrawEdge, SetFontName,
SetFontFace, SetFontSize, DrawArc, SetJustification, SetColor, black, invert,
currentJustification, currentFontSize, SetCaret,
GetRopeDispl, Whiten],
JunoUserEvents USING [bugout, Event, Next, EventCoords, Blink, StartUp, Terminate],
IO USING [PutF, real], -- DEBUG
JunoProcViewer USING [AddDef, StartUp, Terminate],
ViewerClasses USING [Viewer],
ViewerTools USING [GetSelectionContents],
Rope USING [ROPE, FromChar, Cat, IsEmpty, Substr, Length],
Convert USING [RopeFromInt, RopeFromReal],
Process USING[Detach],
Atom USING[GetPName, MakeAtom];

JunoTop: PROGRAM

IMPORTS

JunoImage,
JunoStorage,
JunoBody,
JunoMatrix,
JunoGraphics,
JunoAlgebra,
JunoUserEvents,
JunoProcViewer,
IO, -- DEBUG
JunoUserEventsImpl, -- DEBUG
Rope,
Convert,
ViewerTools,
Process,
Atom

=

BEGIN

OPEN

Im: JunoImage,
Solv: JunoOldSolver,
Body: JunoBody,
Stor: JunoStorage,
Evs: JunoUserEvents,
JunoUserEventsImpl, -- DEBUG
Gr: JunoGraphics,
Alg: JunoAlgebra,
Mat: JunoMatrix,
PView: JunoProcViewer,
Rope;

Point: TYPE = Stor.Point;

Coords: TYPE = Stor.Coords;

Action: TYPE = Stor.Action;

Constr: TYPE= Stor.Constr;

debug1, debug2: BOOL ← FALSE; -- can be set by BugBane to avoid debug output

- - - - ARGUMENT QUEUES

argMax: INTEGER = 50; -- max num. of arguments in each queue

Queue: TYPE = REF QueueRec;

QueueRec: TYPE = RECORD
[top: [0 .. argMax] ← 0,
a: ARRAY [1 .. argMax] OF RECORD
[p: Point, sy: Gr.PointSymbol]];

The symbol used for a point depends on how many points with same rouded coordinates are already there.

que: Queue = NEW[QueueRec];

There used to be a secondary queue, but its duties have been taken over by the primary one.

L1Dist: PROC [p, q: Coords] RETURNS [REAL] = INLINE {RETURN[ABS[p.x-q.x]+ABS[p.y-q.y]]};

HilyteElem: PROC [ix: INTEGER] =
Recomputes a[ix].c and a[ix].sy and paints a[ix].p accordingly.
Assumes it is currently not highlighted.

{OPEN que;
a[ix].sy ← FIRST[Gr.PointSymbol];
FOR k: INTEGER DECREASING IN [1..ix) DO
IF L1Dist[a[k].p.coords, a[ix].p.coords] < 1 THEN
{a[ix].sy ← IF a[k].sy >= box THEN box ELSE SUCC[a[k].sy]; EXIT}
ENDLOOP;
Gr.Hilyte[a[ix].p.coords, a[ix].sy]};

Push: PROC [p: Point] =
Adds p to the "top" end of queue q.
Highlights it as appropriate.

{OPEN que;
IF p=NIL THEN ERROR;
top ← top + 1; a[top].p ← p;
HilyteElem[top]};

Pop: PROC [] =
Removes the oldest ("bottom") point from q.

{OPEN que;
IF top = 0 THEN ERROR;
Gr.Hilyte[a[1].p.coords, a[1].sy];
FOR i: INTEGER IN [1 .. top) DO
Gr.Hilyte[a[i+1].p.coords, a[i+1].sy];
a[i] ← a[i + 1];
HilyteElem[i]
ENDLOOP;
top ← top - 1};

RefreshQueue: PROC [] =
Highlights again the points in the argument queue.
Assumes none of them is highlighted. Does not recompute the counts.

{OPEN que;
FOR i: INTEGER IN [1..top] DO
Gr.Hilyte[a[i].p.coords, a[i].sy]
ENDLOOP};

FlushArgumentQueues: PROC =
Removes (and unpaints) all points from the argument queue.

{OPEN que;
FOR i: INTEGER IN [1 .. top] DO Gr.Hilyte[a[i].p.coords, a[i].sy] ENDLOOP;
top ← 0};

- - - - MOUSE EVENT PARSER

The procedures in this section parse the stream of user events (as conditioned by the JunoUserEvents module) and perform the appropriate actions on the current image.

ev: Evs.Event; -- the user event last returned by Evs.Next

Unexpected: SIGNAL = CODE; -- parse/lexer found an event that could't possibly be there

EvCoords: PROCEDURE RETURNS [Coords] = INLINE {RETURN[[ev.coords.x, ev.coords.y]]};

Returns the coordinates of the curent event ev, assuming it is a mouse one (Roll, MouseUp, MouseDown).

MainLoop: PROC =

Parses and executes each user command.

BEGIN

prevCmd: ATOM ← $Missing;

ParseNextCommand: PROC =

Should be called with ev.type = Cursor or Button. Will return with ev.type = End.

ABORTED signals are caught here, if they have not been caught by the individual commands.

BEGIN ENABLE {ABORTED => {GOTO CommandAborted}};

cmd: ATOM = NARROW [ev.value];

Reset image to a reasonably clean state:

ClearPoints: Im.PointVisitProc = {p.wn ← 0; p.fixed ← p.frozen; p.mark ← FALSE};
Im.EnumPoints[ClearPoints];
Gr.SetScreenContext[];

IF cmd # $Typewriter THEN
{refPosDefined ← FALSE; refPoint ← NIL;
Gr.SetCaret[on: FALSE]};

IF prevCmd # cmd THEN
{FlushArgumentQueues[];
prevCmd ← cmd};

SELECT cmd FROM

$Pencil =>

{ParseTypicalCmdBody
[maxPrim: 4, nLeave: 1, ProcessPoints: DrawThem]};

$Compass =>

{ParseTypicalCmdBody
[maxPrim: 4, nLeave: 2, ProcessPoints: CongThem, solve: TRUE]};

$HorTee =>

{ParseTypicalCmdBody
[maxPrim: 2, nLeave: 1, ProcessPoints: HorThem, solve: TRUE]};

$VerTee =>

{ParseTypicalCmdBody
[maxPrim: 2, nLeave: 1, ProcessPoints: VerThem, solve: TRUE]};

$Parallels =>

{ParseTypicalCmdBody
[maxPrim: 4, nLeave: 2, ProcessPoints: ParaThem, solve: TRUE]};

$RightAngle =>

{ParseTypicalCmdBody
[maxPrim: 4, nLeave: 2, ProcessPoints: PerpThem, solve: TRUE]};

$CallProc =>

{ParseTypicalCmdBody
[maxPrim: argMax, ProcessPoints: CallProcOnThem,
solve: FALSE, refresh: FALSE]};

$MoveArrow =>

{ParseTypicalCmdBody
[maxPrim: 3, baloonSel: TRUE, ProcessPoints: MoveThem, solve: TRUE]};

$CopyArrow =>

{ParseTypicalCmdBody
[maxPrim: 3, baloonSel: TRUE, ProcessPoints: CopyThem, solve: TRUE]};

$MakeProc =>

{ParseTypicalCmdBody
[maxPrim: argMax, baloonSel: TRUE,
ProcessPoints: MakeProcOfThem, solve: FALSE, refresh: FALSE]};

$Eraser =>

{ParseTypicalCmdBody
[create: FALSE, baloonSel: TRUE, ProcessPoints: DeleteThem, solve: TRUE]};

$Snowman =>

{ParseFreezeCmd []};

$Typewriter =>

{ParseTypeCmd []};

$Hardcopy =>

{ParseButtonCmdBody
[ProcessArgs: DoHardcopy, solve: FALSE, refresh: FALSE]};

$Redraw =>

{ParseButtonCmdBody
[ProcessArgs: DoRedraw, solve: FALSE, refresh: TRUE]};

$Solve =>

{ParseButtonCmdBody
[ProcessArgs: DoSolve, solve: TRUE]};

$StartOver =>

{ParseButtonCmdBody [ProcessArgs: DoStartOver, solve: FALSE, refresh: TRUE]};

$SetFontName, $SetFontSize, $SetFontFace, $SetJustification =>

{ParseButtonCmdBody
[ProcessArgs: DoSetOption, solve: FALSE, refresh: FALSE]};

ENDCASE => {ERROR Unexpected};

IF ev.type # End THEN {ERROR Unexpected} -- command didn't get to End

EXITS

CommandAborted =>

{Evs.Blink["command aborted!"];
WHILE ev.type # End DO ev ← Evs.Next[] ENDLOOP}

END;

Body of main loop:

Evs.StartUp[];
PView.StartUp[];

DO

ev ← Evs.Next[];
IF ev.type = Quit THEN EXIT;
ParseNextCommand[]

ENDLOOP;

Evs.Terminate[];
PView.Terminate[]

END;

- - - - GENERAL-PURPOSE PARSING TOOLS

TypicalCommandProc: TYPE = PROC [terminator: ATOM];

A TypicalCommandProc is called by ParseTypicalCmdBody to process each segment of the command (i.e., the pieces up to each terminator).

The arguments to the TypicalCommandProc (i.e., the moused points in that segment) will be in the primary argument queue and/or will have wn#0, depending on how they were selected.

The TypicalCommandProc is called only with terminator = $Escape, $Return, or $Tab.

ParseTypicalCmdBody: PROC
[maxPrim, nLeave: INT ← 0,
create: BOOL ← TRUE, baloonSel: BOOL ← FALSE,
ProcessPoints: TypicalCommandProc, solve, refresh: BOOL ← FALSE] =

Parses the body of simple commands acording to the syntax
<mouse clicks> End
where the <mouse clicks> are as accepted by ParseMousedPoints.

On entry, ev should be Cursor or Button. On exit, it will be End.

The nLeave parameter is the number of points to be left on the primary argument queue (eg., nLeave=1 for draw, =2 for cong).

If solve = TRUE and the End-ing event is $Escape or $Return, ProcessPoints is called, the constraints are solved again, and the image is repainted. Note that the p.fixed and p.frozen bits may be set by ProcessPoints to prevent the solver from moving a point p. The p.fixed bit will be reset before the next user command is executed.

If solve=FALSE or the End-ing event is $Tab, ProcessPoints is called, but the constraints are NOT solved. The image will be repainted (with the current positions of the points) if refresh=TRUE.

Finally, if the End-ing event is $Delete or $None, ProcessPoints is not called; the argument queues are cleared, and no solving or repainting takes place.

BEGIN

terminator: ATOM;

ParseMousedPoints [maxPrim, create, baloonSel];

IF ev.type # End THEN {ERROR Unexpected};
terminator ← NARROW [ev.value];

SELECT terminator FROM

$None, $Delete => {FlushArgumentQueues[]};

$Escape, $Tab, $Return =>

{ProcessPoints[terminator];
WHILE que.top > 0 AND que.top # nLeave DO Pop[] ENDLOOP;
IF solve AND terminator = $Escape OR terminator = $Return THEN
{SolveAndRefresh[]}
ELSE IF refresh THEN
{Refresh[]}};

ENDCASE => {ERROR Unexpected};

END;

ParseMousedPoints: PROC
[maxPrim: INT ← 0, create: BOOL ← TRUE, baloonSel: BOOL ← FALSE] =

Parses a sequence of mouse clicks that specifies the arguments to a typical command.

The parsed sequence consists of zero to maxPrim "primary" points (either new ones created with red clicks, or old ones selected with yellow clicks), plus, if baloonSel=TRUE, any number of "baloon-selected" or "wound" points (old ones selected by circling them with the mouse while the blue button is held down). Multiple blue baloons are cumulative. The two kinds of selections may be freely intermixed and may include the same point(s). The order and multiplicity of the primary arguemnts is important in general.

Red clicks (point creation) are allowed only if create=TRUE. All mouse clicks will track the mouse until the button is released.

The least recent entries in the primary queue are automatically removed if the length of the latter exceeds maxPrim. Setting maxPrim to zero disables primary selections.

Should be called with ev= event before point list (i.e., Cursor or Button). On return, ev is End. Events of type Char, Backspace, Atom, Real, and Rope are flagged and ignored.

BEGIN

DO

ev ← Evs.Next[];
SELECT ev.type FROM

MouseDown =>

SELECT ev.value FROM

$Red =>

{IF create THEN
IF maxPrim <= 0 THEN
{Evs.Blink ["Primary selections not allowed"]}
ELSE
{coords: Coords = ParseMousedCoords[];
Push[AddNewPoint [coords, TRUE]];
bugout.PutF["ParseMousedPoints: new point at [%g, %g]",
IO.real[coords.x], IO.real[coords.y]]; -- DEBUG
 WHILE que.top > maxPrim DO Pop [] ENDLOOP}
ELSE
{Evs.Blink ["Point creation not allowed"]}};

$Yellow =>

{IF maxPrim <= 0 THEN
{Evs.Blink ["Primary selections not allowed"]}
ELSE
{p: Point = ParseMouseSelectedPoint[wound: FALSE];
IF p # NIL THEN
{Push[p];
bugout.PutF["ParseMousedPoints: old point at [%g, %g]",
IO.real[p.coords.x], IO.real[p.coords.y]]; -- DEBUG
WHILE que.top > maxPrim DO Pop[] ENDLOOP}
ELSE
{Evs.Blink ["No point found"]}}};

$Blue =>

{IF baloonSel THEN
{TrackBlueBaloon[];
IF NOT Im.AnyWoundPoints[] THEN
{Evs.Blink ["Warning - no points selected"]}}
ELSE
{Evs.Blink ["Baloon selections not allowed"]}};

ENDCASE => {SIGNAL Unexpected};

Char, Atom, Rope, Real, BackSpace =>

{Evs.Blink ["Invalid input"]};

End =>

{RETURN};

ENDCASE => {SIGNAL Unexpected};

ENDLOOP;

END;

ParseMousedCoords: PROC RETURNS [coords: Coords] =

Parses a <mouse click>, returning its coordinates.

Does not allocate a new Point, and does not affect the argument queue. Will track the mouse continuously, highlighting its current position, until the button is released. The point is not highlighted on exit.

Should be called with ev=MouseDown. Returns with ev=MouseUp.

{DO
coords ← EvCoords[];
IF ev.type = MouseUp THEN RETURN;
Gr.Hilyte[coords, cross];
ev ← Evs.Next[];
IF ev.type # Roll AND ev.type # MouseUp THEN ERROR Unexpected;
Gr.Hilyte[coords, cross]
ENDLOOP};

ParseMouseSelectedPoint: PROC [wound: BOOL ← FALSE] RETURNS [point: Point ← NIL] =

Parses a <mouse click>, returning the point nearest to the clicked coordinates (or NIL if couldn't find such point).

Does not allocate a new Point, and does not affect the argument queue. Will let the selected point track the mouse, highlighting it, until the button is released. The point is not highlighted on exit.

If wound = TRUE, considers only points that have wn#0.

Should be called with ev=MouseDown. Returns with ev=MouseUp.

{DO
point ← Im.FindPoint[coords: EvCoords[], wound: wound];
IF ev.type = MouseUp THEN RETURN;
IF point # NIL THEN
{Gr.Hilyte[point.coords, cross]}
ELSE
{Evs.Blink ["No point found"]};
ev ← Evs.Next[];
IF ev.type # Roll AND ev.type # MouseUp THEN ERROR Unexpected;
IF point # NIL THEN
{Gr.Hilyte[point.coords, cross]}
ENDLOOP};

TrackBlueBaloon: PROCEDURE =

The effect of TrackBlueBaloon is to track the cursor until the Blue button is released, setting the wn (winding number) field for all image points contained in the loop made by the cursor.

Should be called with ev.type = $BlueDown. Returns with ev = $BlueUp.

BEGIN

prev: Stor.IntCoords;

NextBluePoint: Im.NextPointProc =

BEGIN
-- Waits for the mouse to move far enough, or blue button to go up,
-- and returns its coordinates.
 DO
ev ← Evs.Next[];
IF ev.type # Roll AND ev.type # MouseUp THEN {SIGNAL Unexpected; LOOP};
lastPoint ← ev.type = MouseUp;
IF lastPoint
OR ABS[ev.coords.x - prev.x] > 5 OR ABS[ev.coords.y - prev.y] > 5 THEN
{coords ← ev.coords; Gr.DrawChar[EvCoords[], '.]; RETURN}
ENDLOOP
END;

prev ← ev.coords;
Gr.DrawChar[EvCoords[], '.];
Im.BaloonSelect[prev, NextBluePoint]

END;

AddNewPoint: PUBLIC PROC [coords: Coords, visible: BOOL ← TRUE] RETURNS [p: Point] =

BEGIN
p ← Stor.NewPoint[coords, visible];
IF visible THEN Gr.DrawPoint[p.coords];
Im.AddPoint[p]
END;

ButtonCommandProc: TYPE = PROC [button: ATOM];

A ButtonCommandProc is called by ParseButtonCmdBody to process the body of a typical Button command.

The ButtonCommandProc is called with ev = first button argument (or End if none). It should return with ev=End.

ParseButtonCmdBody: PROC
[ProcessArgs: ButtonCommandProc, solve, refresh: BOOL ← FALSE] =

Parses the body of button commands, that obeys the syntax
<button arguments, mouse clicks, and keyboard events> End
where the arguments are as accepted by the given ButtonCommandProc.

On entry, ev should be Cursor or Button. On exit, ev will be the event following the End (next Cursor or Button).

If solve = TRUE, ProcessArgs is called, the constraints are solved again, and the image is repainted. Note that the p.fixed and p.frozen bits may be set by the ButtonCommandProc to prevent the solver from moving a point p. The p.fixed bit will be reset before the next user command is executed.

If solve=FALSE, ProcessArgs is called, but the constraints are NOT solved. The image will be repainted (with the current positions of the points) if refresh=TRUE.

BEGIN

button: ATOM = NARROW[ev.value];
ev ← Evs.Next[];

ProcessArgs[button];

IF ev.type # End THEN {ERROR Unexpected};

IF solve THEN
{SolveAndRefresh[]}
ELSE IF refresh THEN
{Refresh[]}

END;

AddNewAction: PROC [kind: Stor.ActionKind, args: Stor.ActionArgs, doIt: BOOL ← FALSE] =

BEGIN

a: Action;
IF doIt THEN ExecuteAction[kind: kind, args: args ! ABORTED => {GOTO SkipIt}];
a ← Stor.NewAction [kind: kind, args: args];
Im.AddAction [a];

EXITS

SkipIt => {}

END;

- - - - SIMPLE COMMANDS

DrawThem: TypicalCommandProc =

BEGIN
IF que.top = 3 OR que.top = 1 THEN Pop[];
IF que.top = 0 THEN
{RETURN}
ELSE
{AddNewAction
[kind: draw,
args: IF que.top = 2
THEN LIST[que.a[1].p, que.a[2].p]
ELSE LIST[que.a[1].p, que.a[2].p, que.a[3].p, que.a[4].p],
doIt: TRUE]}
END;

CongThem: TypicalCommandProc =

BEGIN
IF que.top # 4 THEN
{WHILE que.top > 0 DO Pop[] ENDLOOP; RETURN}
ELSE
{Im.AddConstr[Stor.NewCong[que.a[1].p, que.a[2].p, que.a[3].p, que.a[4].p]]}
END;

ParaThem: TypicalCommandProc =

BEGIN
IF que.top # 4 THEN
{WHILE que.top > 0 DO Pop[] ENDLOOP; RETURN}
ELSE
{Im.AddConstr[Stor.NewPara[que.a[1].p, que.a[2].p, que.a[3].p, que.a[4].p]]}
END;

PerpThem: TypicalCommandProc =

BEGIN
IF que.top # 4 THEN
{WHILE que.top > 0 DO Pop[] ENDLOOP; RETURN}
ELSE
{Im.AddConstr[Stor.NewPerp[que.a[1].p, que.a[2].p, que.a[3].p, que.a[4].p]]}
END;

HorThem: TypicalCommandProc =

BEGIN
IF que.top # 2 THEN
{WHILE que.top > 0 DO Pop[] ENDLOOP; RETURN}
ELSE
{Im.AddConstr[Stor.NewHor[que.a[1].p, que.a[2].p]]}
END;

VerThem: TypicalCommandProc =

BEGIN
IF que.top # 2 THEN
{WHILE que.top > 0 DO Pop[] ENDLOOP; RETURN}
ELSE
{Im.AddConstr[Stor.NewVer[que.a[1].p, que.a[2].p]]}
END;

DeleteThem: TypicalCommandProc =

BEGIN
Im.DeleteWoundItems[]
END;

- - - - PROCEDURE CREATION AND INVOCATION COMMANDS

lastProc: ATOM ← $X;

CallProcOnThem: TypicalCommandProc =

BEGIN

r: ROPE ← ViewerTools.GetSelectionContents[];
proc: ATOM ← Atom.MakeAtom[r];
args: Stor.ActionArgs ← NIL;
FOR i: INTEGER DECREASING IN [1 .. que.top) DO
args ← Stor.Cons[que.a[i].p, args]
ENDLOOP;
{FixIt: Im.PointVisitProc={p.fixed ← TRUE}; Im.EnumPoints[FixIt]};
AddNewAction [kind: call, args: Stor.Cons[proc, args], doIt: TRUE]

END;

MakeProcOfThem: TypicalCommandProc =

BEGIN

np: INTEGER ← 0; -- number of points named so far

NamePoint: Im.PointVisitProc =

BEGIN
letter: ROPE = Rope.FromChar['a + np MOD 26];
p.name ← Atom.MakeAtom[IF np > 25
THEN Rope.Cat[letter, Convert.RopeFromInt[np/26, 10, FALSE]]
ELSE letter];
np ← np+1;
Gr.DrawRope[[p.coords.x + 5, p.coords.y + 5], Atom.GetPName[p.name]]
END;

formals, body, proc: Alg.Se;

frame: Stor.Frame;

Erase all point names, and reset their fixed flag:

{UnNam: Im.PointVisitProc={p.name←NIL; p.fixed←FALSE}; Im.EnumPoints [UnNam]};

Name the formal parameters, make a nest of them, and mark them as fixed:

IF que.top = 0 THEN
{formals ← NIL}
ELSE
{NestEm: PROC [i: INTEGER] RETURNS [f: Alg.Se] =
{p: Point = que.a[i].p;
IF p.name # NIL THEN {Evs.Blink["Repeated formal parameter"]; ERROR};
NamePoint[p];
p.fixed ← TRUE;
formals ← IF i=que.top
THEN p.name
ELSE LIST[Alg.comma, p.name, NestEm[i+1]]};

formals ← NestEm[1]};

Get reference frame for local hints:

frame ←
[org: IF que.top > 0 THEN que.a[1].p ELSE NIL,
hor: IF que.top > 1 THEN que.a[2].p ELSE NIL,
ver: IF que.top > 2 THEN que.a[3].p ELSE NIL];

Name the other points :

{Name: Im.PointVisitProc = {IF p.wn#0 AND p.name = NIL THEN NamePoint[p]};
Im.EnumPoints [Name]};

Build the body of the lambda:

body ← Body.MakeBody[frame];

Build the lambda and add it to the list:

proc ← LIST [Alg.lambda, formals, body];
PView.AddDef [name: NIL, value: proc] -- name=NIL means make it up

END;

- - - - FREEZE COMMAND

ParseFreezeCmd: PROC =

BEGIN

HilyteIfFrozen: Im.PointVisitProc =

{IF p.frozen THEN Gr.Hilyte[p.coords, diamond]};

Im.EnumPoints[HilyteIfFrozen]; -- Highlight currently frozen points

DO

ev ← Evs.Next[];
SELECT ev.type FROM

MouseDown =>

{IF ev.value = $Yellow THEN
{p: Point = ParseMouseSelectedPoint[wound: FALSE];
IF p # NIL THEN
{p.frozen ← NOT(p.frozen);
p.fixed ← p.frozen;
Gr.Hilyte[p.coords]}}
ELSE
{Evs.Blink ["Yellow button, please"];
WHILE ev.type # MouseUp DO ev ← Evs.Next[] ENDLOOP}};

Char, BackSpace, Atom, Rope, Real =>

{Evs.Blink ["Invalid input"]};

End =>

{IF ev.value = $Escape THEN
{SolveAndRefresh[]}
ELSE IF ev.value # $Tab AND ev.value # $None THEN
{Evs.Blink ["Invalid input"]};
EXIT};

ENDCASE => {ERROR Unexpected};

ENDLOOP;

Im.EnumPoints[HilyteIfFrozen] -- Erase all highlights

END;

- - - - MOVE AND COPY COMMANDS

MoveThem: TypicalCommandProc =

BEGIN
MoveOrCopyThem[copy: FALSE]
END;

CopyThem: TypicalCommandProc =

BEGIN
MoveOrCopyThem[copy: TRUE]
END;

mat: REF Mat.Matrix ← NEW [Mat.Matrix]; -- transform matrix for move/copy commands

MoveOrCopyThem: PROC [copy: BOOLEAN] =

A procedure used in both the Move and Copy commands.

The primary arguments should come in one or more pairs (from, to). If there are no baloon-selected points, then all "from" points are moved to the corresponding "to" points.
If there are blue-selected points, then only these are moved, according to an affine transformation specified by the primary arguments. The latter must come in one to three pairs; the transformation is the one mapping the "from" points into the "to" ones.

If copy=TRUE, the points to be moved are first duplicated, and the motion appied to the copies. All constraints and actions that involve only copied points are copied as well.

In either case, when a "from" point moves and the corresponding "to" doesn't, the two are replaced by a single point in all actions and constraints where they occurs.

The motion occurs irrespective of the frozen/unfrozen status of the selected points. After the motion, the points that were moved will be temporarily fixed in their new positions, till the next command.

This procedure assumes all copy links are NIL on entry, all points in the source frame have wn#0, and all points in the destination frame have wn=0.

BEGIN

n: INTEGER = que.top/2;
singular: BOOL ← FALSE;
baloon: BOOL = Im.AnyWoundPoints[];

MoveIt: PROC [p: Point, c: Coords] = INLINE
{p.coords ← c; p.wn ← 0; p.fixed ← TRUE};

IF que.top MOD 2 # 0 OR que.top=0 THEN
{Evs.Blink["Please select one or more pairs (from, to)"]; RETURN};

If there are blue-selected points, then the points on the argument queue must be a pair of interleaved frames specifying a non-singular affine transformation. If not, the "from" points in the queue are automatically blue-selected for copying.

IF baloon THEN
{OPEN que;
from, to: Stor.Frame ← [NIL, NIL, NIL];
IF top > 6 THEN
{Evs.Blink["Reference frames may have at most three pairs of points"]; RETURN};
from.org ← a[1].p; to.org ← a[2].p;
IF n>1 THEN {from.hor ← a[3].p; to.hor ← a[4].p};
IF n>2 THEN {from.ver ← a[5].p; to.ver ← a[6].p;
[mat, singular] ← Mat.ComputeTransform[from, to, mat];
IF singular THEN
{Evs.Blink["Singular transformation"]; RETURN}}}
ELSE
{FOR i: INTEGER 𡤁, i+2 WHILE i<que.top DO
que.a[i].p.wn ← 1
ENDLOOP};

If copy, duplicate all points to be moved and apply the move to them.

IF copy THEN
BEGIN

Im.DuplicateWoundItems[];

Im.DuplicateWoundItems will
a) copy the points with wn#0 (& attached constraints &actions);
b) add the copies to the current image,
c) set the copy link of the originals to the copies,
d) set the copy links of the copies to NIL,
e) set the wn's of the copies to the wn's of the originals,
f) set the wn's of the originals to zero
(i.e. take out the originals from the baloon, and put in the copies).

Now replace all "from" points in the queue by their copies

FOR i: INTEGER ← 1, i+2 WHILE i<n+n DO
IF que.a[i].p.copy # NIL THEN
{que.a[i].p ← que.a[i].p.copy}
ENDLOOP;

Now reset copy links of all points

{Reset: Im.PointVisitProc = {p.copy ← NIL}; Im.EnumPoints[Reset]};

END;

Forcefully move every "from" point with wn#0 to the corresponding "to" point, and identify the two (unless the "to" point moves, too).

FOR i: INTEGER ← 1, i+2 WHILE i < n+n DO
from: Point = que.a[i].p;
to: Point = que.a[i+1].p;
IF from.wn#0 THEN
{MoveIt[from, to.coords];
IF to.wn = 0 THEN
{from.copy ← to}}
ENDLOOP;
Im.IdentifyPoints[];

Move the remaining wound points according to the affine transformation.

IF baloon THEN
{Map: Im.PointVisitProc = {IF p.wn#0 THEN MoveIt[p, Mat.MapCoords[p.coords, mat]]};
Im.EnumPoints [Map];
Im.SortPoints[]};

END;

- - - - TYPEIN COMMAND

oldRope: ROPE ← NIL; -- last type-in, for defaulting

refPos: Coords;
refPoint: Point ← NIL;
refPosDefined: BOOL ← FALSE;
if TRUE, refPos (and refPoint, if not NIL) is the default position for next typein

ParseTypeCmd: PROC =

BEGIN

rope: ROPE ← NIL;

ParseRefPos: PROC =
Parses a red/yellow click, returns it in refPos (and refPoint if old).
To be called with ev.type = MouseDown, returns with ev.type=MouseUp.
sets refPosDefined (unless failed to find the point).

BEGIN

SELECT ev.value FROM

$Red =>

{refPos ← ParseMousedCoords[];
Gr.SetCaret [coords: refPos];
refPosDefined ← TRUE};

$Yellow =>

{p: Point = ParseMouseSelectedPoint[];
IF p # NIL THEN
{refPos ← p.coords; refPoint ← p;
Gr.SetCaret [coords: refPos];
refPosDefined ← TRUE}
ELSE
{-- leave as is --}};

$Blue =>

{Evs.Blink ["Red or yellow button, please"]};

ENDCASE => {ERROR Unexpected};

END;

ChangeRope: PROC [new: ROPE] =
Replace rope by new and repaints it. Assumes caret is on.

BEGIN

IF NOT rope.IsEmpty[] THEN
{Gr.DrawRope[refPos, rope]}; -- erase old rope
rope ← new;
Gr.DrawRope[refPos, rope]; -- paint new one
IF Gr.currentJustification # $right THEN
{-- must move caret
 vec: Coords ← Gr.GetRopeDispl [rope];
IF Gr.currentJustification = $center THEN {vec ← [0.5*vec.x, 0.5*vec.y]};
Gr.SetCaret [coords: [refPos.x+vec.x, refPos.y+vec.y]]};

END;

AddTheRope: PROC [newLine: BOOL] =
Adds rope to the current image (if not NIL) at the current position, allocating the point if necessary. Also sets oldRope ← rope, rope ← NIL.

If newLine = TRUE, advances refPos (and caret) to the next line.
If newLine =FALSE and rope was # NIL, turns off caret and sets refPosDefined ← FALSE.

BEGIN

IF rope.IsEmpty[] THEN RETURN;

oldRope ← rope; -- save oldRope in case user just hits ESC next time
-- create new point, if needed
IF refPoint = NIL THEN
{refPoint ← AddNewPoint [coords: refPos, visible: FALSE]};
-- add print action
AddNewAction [kind: print, args: LIST [rope, refPoint], doIt: FALSE];
rope ← NIL;

IF newLine THEN
{refPos ← [refPos.x, refPos.y - Gr.currentFontSize];
Gr.SetCaret [coords: refPos];
refPoint ← NIL; refPosDefined ← TRUE}
ELSE
{Gr.SetCaret [on: FALSE];
refPoint ← NIL; refPosDefined ← FALSE};

END;

Body of parseTypeCmd:

BEGIN

IF refPosDefined THEN Gr.SetCaret [coords: refPos];
[] ← Gr.SetColor[Gr.invert];

DO

ev ← Evs.Next[];

SELECT ev.type FROM

Char, Rope, Atom, BackSpace, Real =>

{IF NOT refPosDefined THEN
{Evs.Blink ["Please select reference point"]}
ELSE
{new: ROPE = SELECT ev.type FROM
Char => rope.Cat [FromChar[NARROW[ev.value, REF CHAR]^]],
BackSpace => IF rope.IsEmpty THEN rope ELSE
rope.Substr [0, rope.Length[] - 1],
Rope => NARROW[ev.value, ROPE],
Real => Convert.RopeFromReal[NARROW[ev.value, REF REAL]^],
Atom => Atom.GetPName[NARROW[ev.value, ATOM]],
ENDCASE => ERROR;
ChangeRope[new]}};

MouseDown =>

{AddTheRope [FALSE];
ParseRefPos};

End =>

{IF ev.value = $Delete THEN
{ChangeRope[NIL]};
IF rope.IsEmpty[]
AND NOT oldRope.IsEmpty[]
AND ev.value=$Escape THEN {ChangeRope[oldRope]};
AddTheRope [newLine: ev.value = $Return];
RETURN};

ENDCASE => {ERROR Unexpected};

ENDLOOP

END

END;

- - - - CONSTRAINT SOLVING AND IMAGE REFRESH

SolveAndRefresh: PROC =
Solves the current set of constraints for all points that have p.fixed=FALSE.

BEGIN
SELECT Im.SolveImage[0.1] FROM
true => {};
uncertain => {Evs.Blink["The solver didn't converge."]};
false => {Evs.Blink["The solver failed."]};
ENDCASE;
Refresh[]
END;

Refresh: PROCEDURE =
Repaints the current image on the current context (screen or hardcopy).
Will set p.fixed=TRUE for all points, so that procedure calls will not move them
(except by assignment).

BEGIN
FixIt: Im.PointVisitProc={p.fixed ← TRUE};
DoIt: Im.ActionVisitProc = {ExecuteAction [a.kind, a.args]};
ShowIt: Im.PointVisitProc = {IF p.visible THEN Gr.DrawPoint [p.coords]};
Gr.Whiten[];
[] ← Gr.SetColor[Gr.black];
Im.EnumPoints[FixIt];
Im.EnumActions[DoIt];
Im.EnumPoints[ShowIt];
[] ← Gr.SetColor[Gr.invert];
RefreshQueue[]
END;

- - - - ACTION SEMANTICS

ExecuteAction: PUBLIC PROC [kind: Stor.ActionKind, args: Stor.ActionArgs] =

BEGIN
SELECT kind FROM

draw =>

{IF args.rest.rest=NIL THEN
{p: Coords = NARROW [args.first, Point].coords;
q: Coords = NARROW [args.rest.first, Point].coords;
Gr.DrawEdge[p, q, TRUE]}
ELSE
{p: Coords = NARROW [args.first, Point].coords;
r: Coords = NARROW [args.rest.first, Point].coords;
s: Coords = NARROW [args.rest.rest.first, Point].coords;
q: Coords = NARROW [args.rest.rest.rest.first, Point].coords;
Gr.DrawArc[p, r, s, q, TRUE]}};

print =>

{rope: Rope.ROPE = NARROW[args.first];
p: Point = NARROW[args.rest.first];
Gr.DrawRope [coords: p.coords, rope: rope]};

font =>

{font: ROPE = NARROW[args.first];
[] ← Gr.SetFontName[font]};

face =>

{face: ATOM = NARROW[args.first];
[] ← Gr.SetFontFace[face]};

size =>

{size: REAL = NARROW[args.first, REF REAL]^;
[] ← Gr.SetFontSize[size]};

justify =>

{justification: ATOM = NARROW[args.first];
[] ← Gr.SetJustification[justification]};

call =>

{Alg.Call[func: NARROW[args.first], args: NARROW [args.rest]
! ABORTED => CONTINUE];
Im.SortPoints[]};

ENDCASE =>

{ERROR};

END;

- - - - BUTTON PROCEDURES

The following procedures are called via PArseButtonCmd.

DoHardcopy: ButtonCommandProc =

Should be called with solve=FALSE, refresh=FALSE.

{filename: Rope.ROPE = NARROW [ev.value];
ev ← Evs.Next[];
Gr.SetPaperContext[$Puffin, filename];
Refresh[];
Evs.Blink["press file created: ", filename]};

DoRedraw: ButtonCommandProc = {};

Should be called with solve=FALSE, refresh=TRUE.

DoSolve: ButtonCommandProc = {};

Should be called with solve=TRUE

DoStartOver: ButtonCommandProc =

Should be called with solve=FALSE, refresh=TRUE.

{Im.PurgeImage [];
[] ← Gr.SetJustification[$left];
oldRope ← NIL};

DoSetOption: ButtonCommandProc =

Used by the buttons SetFontName, SetFontSize, SetFontFace, etc.

Should be called with solve=FALSE, refresh=FALSE.

{kind: Stor.ActionKind = SELECT button FROM
$SetFontName => font,
$SetFontSize => size,
$SetFontFace => face,
$SetJustification => justify,
ENDCASE => ERROR;
args: Stor.ActionArgs = Stor.Cons[ev.value, NIL];
ev ← Evs.Next[];
AddNewAction [kind: kind, args: args, doIt: TRUE]};

- - - - INITIALIZATION:

Process.Detach[FORK MainLoop[]]

END.

- - - - JUNK

From JunoTop, April 18, 1984 11:31:01 pm PST:

MoveLast: PROC [new: Coords] =
Changes the coordinates of the top point in q.
The point is highlighted as appropriate to its new position.

{OPEN que;
p: Point ← a[top].p;
IF new # p.coords THEN
{Gr.Hilyte[a[top].p.coords, a[top].sy];
top ← top - 1;
p.coords ← new;
Push[p]}};

RepLast: PROC [p: Point] =
Removes the most recent (top) point from q and pushes p in its place.

{OPEN que;
IF p # a[top].p THEN
{Gr.Hilyte[a[top].p.coords, a[top].sy];
top ← top - 1;
Push[p]}};

TrackOldPoint: PROC [wound: BOOL ← FALSE] =

Continuously replaces the top of the primary or secondary argument queue by the image point that is closed to the current mouse coordinates, until the mouse button is released.

Should be called with ev.type = $RedDown, $YellowDown, or $BlueDown. Returns with ev=$RedUp, $YellowUp, $BlueUp.

If wound=TRUE considers only points within the blue baloon (i.e. with nonzero winding number).

BEGIN

p: Point;

DO
ev ← Evs.Next[];
IF ev.type = MouseUp THEN RETURN;
IF ev.type # Roll THEN {SIGNAL Unexpected; LOOP};
p ← Im.FindPoint [coords: EvCoords[], wound: wound];
RepLast[p];
ENDLOOP

END;

TrackNewPoint: PROC [] =

Continuously updates the coordinates of the top of the primary or secondary argument queue by the current mouse coordinates, until the mouse button is released.

Should be called with ev.type = $RedDown, $YellowDown, or $BlueDown. Returns with ev=$RedUp, $YellowUp, $BlueUp.

BEGIN
DO
ev ← Evs.Next[];
IF ev.type = MouseUp THEN RETURN;
IF ev.type # Roll THEN {SIGNAL Unexpected; LOOP};
MoveLast[EvCoords[]];
ENDLOOP
END;

From ParseTypeCmd, April 18, 1984 11:31:01 pm PST:

ParseString: PROC [coords: Coords, default: ROPE] RETURNS [myRope: ROPE] =
Parses an input rope, displaying it at coords; returns it in myRope.
Called with ev.type = Char or BackSpace, returns with ev.type = End or MouseDown
If user hits Escape with no characters, uses default.

BEGIN

myRope ← NIL;
DO


SELECT ev.type FROM

End =>

{SELECT NARROW [ev.value, ATOM] FROM

$None, $Tab =>

{Gr.SetCaret[on: FALSE]; RETURN};

$Escape, $Tab =>

{-- if myRope is empty, use default
 IF myRope.IsEmpty[]
AND NOT default.IsEmpty[]
AND ev.type=$Escape THEN
{ChangeRope[default]};
Carets.StopCaret[primary];
RETURN};

$Escape, $Return =>

{-- if myRope is empty, use default
 IF myRope.IsEmpty[]
AND NOT default.IsEmpty[]
AND ev.type=$Escape THEN
{ChangeRope[default]};
Carets.StopCaret[primary];
RETURN};

$Delete =>

{-- erase myRope
 ChangeRope[NIL]};

BackSpace =>

{-- erase last character
 ChangeRope[myRope.Substr [0, myRope.Length[] - 1]]};

Tab =>

{Evs.Blink["Invalid character"]};

Char =>

{-- append character
 ChangeRope[myRope.Cat [FromChar[NARROW[ev.value, REF CHAR]^]]]};

MouseDown =>

{Evs.Blink["Keyboard input expected"]};

ENDCASE => {SIGNAL Unexpected};

ENDLOOP

END;

ParseRefPoint: PROC RETURNS =
Waits for a red/yellow click, parses it, returns it in refPos (and refPoint if old).
To be called with ev.type = MouseUp, returns with ev.type=MouseDown.
sets refPosDefined (unless failed to find the point).

BEGIN

WHILE ref = NIL DO
ev ← Evs.Next[];

SELECT ev.type FROM

End =>

{IF ev.value # NIL AND ev.value # $Delete THEN
{Evs.Blink ["No reference point - ignored"]};
RETURN};

MouseDown =>

SELECT ev.value FROM

$Red =>

{Push[ref ← AddNewPoint [coords: EvCoords[], visible: TRUE]];
TrackNewPoint[];
Pop []};

$Yellow =>

{ref ← Im.FindPoint[coords: EvCoords[], wound: FALSE];
IF ref # NIL THEN
{Push[ref];
TrackOldPoint[wound: FALSE];
Pop[]}
ELSE
{Evs.Blink ["No point found"]}};

$Blue =>

{Evs.Blink ["Secondary selections not allowed"]};

ENDCASE => {SIGNAL Unexpected};

Char, BackSpace, Rope, Atom, Real =>

{Evs.Blink ["Please select reference point"]};

ENDCASE => {SIGNAL Unexpected};

ENDLOOP

END;

From ???:

ArgListLength: PROC [l: REF ANY] RETURNS [INT] =

{IF ISTYPE[l, ATOM] THEN RETURN [1] ELSE RETURN [1+ ArgListLength[Caddr[l]]]};