-- June 13, 1983 5:05 pm
-- program junoBodyImpl.mesa, coded July 1981 by Greg Nelson
-- This is 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.
DIRECTORY
JunoStorage, RealFns, JunoBody, Atom, Rope, Convert, JunoGraphics;
JunoBodyImpl: PROGRAM IMPORTS JunoStorage, RealFns, Atom, Rope, Convert, JunoGraphics
EXPORTS JunoBody =
BEGIN OPEN JunoStorage;
InsertPoint: PROCEDURE[p:PointPtr] =
BEGIN
temp: PointPtr ← pointLpad;
WHILE temp.link.x < p.x DO temp ← temp.link ENDLOOP;
p.link ← temp.link;
temp.link ← p;
END;
SortPoints: PUBLIC PROC =
{p,q,r, temp: PointPtr;
IF pointLpad = pointRpad THEN RETURN;
p ← pointLpad.link;
q ← p.link;
p.link ← pointLpad;
UNTIL q = pointRpad DO
IF q.x >= p.x THEN {temp ← q.link; q.link ← p; p ← q; q ← temp; LOOP};
-- Insert q into list p, link[p], link[link[p]], which is sorted in DESCENDING order.
r ← p;
WHILE r.link.x > q.x DO r ← r.link ENDLOOP;
temp ← q.link;
q.link ← r.link;
r.link ← q;
q ← temp;
ENDLOOP;
-- Now reverse the list by moving backwards through it:
UNTIL p = pointLpad DO temp ← p.link; p.link ← q; q ← p; p ← temp; ENDLOOP;
pointLpad.link ← q};
Distance: PROCEDURE[x1, y1, x2, y2: REAL] RETURNS [REAL] =
-- this procedure returns the distance between the points (x1,y1)
-- and (x2,y2).
BEGIN RETURN [RealFns.SqRt[(x1-x2)*(x1-x2) + (y1-y2)*(y1-y2)]] END;
FindSelectedPoint: PUBLIC PROCEDURE [x,y:REAL] RETURNS [PointPtr] =
-- This procedure finds the selected point closest to the current mouse coordinates.
-- It is identical to FindPoint except that slink replaces link. This is a good
-- example of why field selectors should be values.
BEGIN
leftpad: PointPtr = pointLpad;
rightpad: PointPtr = pointRpad;
p, champ: PointPtr;
champdistance, pdistance: REAL;
p ← leftpad.slink;
IF p = rightpad THEN RETURN[NIL];
champ ← p;
champdistance ← Distance[p.x, p.y, x, y];
p ← p.slink;
WHILE p # rightpad DO
pdistance ← Distance[p.x, p.y, x, y];
IF pdistance < champdistance THEN BEGIN champ ← p; champdistance ← pdistance END;
p ← p.slink;
ENDLOOP;
RETURN [champ];
END;
-- Now the procedures that are invoked as commands:
-- The move, copy, and delete commands operate on groups, and the former two involve
-- linear transformations, so before giving their code, we give the program that
-- inverts a matrix. It sets "singular" to TRUE if the matrix is singular.
m, m1, mInv: ARRAY [1..3] OF ARRAY [1..3] OF REAL;
singular: PUBLIC BOOLEAN;
Invertm: PROC =
-- Inverts m into mInv by pivoting three times; or sets "singular" flag.
BEGIN
i, j, k, l: INTEGER;
c: ARRAY [1..3] OF INTEGER;
pivoted: ARRAY [1..3] OF BOOLEAN ← [FALSE, FALSE, FALSE];
p: REAL;
-- k is the row in which we are pivoting.
-- l is the column in which we are pivoting.
-- i and j are miscellaneous row and column indices respectively
-- c[i] is the column of the pivot in the ith row.
-- p is the reciprocal of the pivot element; also used as temp for swapping.
singular ← FALSE;
FOR k IN [1..3] DO
-- set l so m[k,l] is largest of m[k,1], m[k, 2], m[k, 3], excluding
-- columns in which we have already pivoted.
p ← 0;
FOR j IN [1 .. 3]
DO IF ABS[m[k][j]] >= p AND NOT pivoted[j] THEN {l ← j; p ← ABS[m[k][l]]} ENDLOOP;
-- We will pivot at m[k,l], if it is not too small:
IF ABS[m[k][l]] < .0001 THEN {singular ← TRUE; RETURN};
c[k] ← l; pivoted[l] ← TRUE;
p ← 1.0 / m[k][l]; m[k][l] ← 1.0;
-- divide everything in pivot row by the pivot element:
FOR j IN [1..3] DO m[k][j] ← m[k][j] * p ENDLOOP;
FOR i IN [1..3] DO
IF i # k THEN
FOR j IN [1..3] DO
IF j # l THEN -- for each m[i,j] outside the pivot row and column
m[i][j] ← m[i][j] - m[i][l] * m[k][j]; -- note that m[k,j] was already * p.
ENDLOOP ENDLOOP;
-- Finally process pivot column:
FOR i IN [1..3] DO IF i # k THEN m[i][l] ← -m[i][l] * p ENDLOOP;
ENDLOOP;
-- Now we permute rows and columns:
FOR i IN [1..3] DO FOR j IN [1..3] DO mInv[c[i]][j] ← m[i][c[j]] ENDLOOP ENDLOOP;
END;
MultiplyMatrix: PROCEDURE =
-- multiply m1 * mInv to produce m.
BEGIN
i, j, k: INTEGER;
sum: REAL;
FOR i IN [1..3] DO FOR j IN [1..3] DO
{sum ← 0.0; FOR k IN [1..3] DO sum ← sum + m1[i][k] * mInv[k][j] ENDLOOP;
m[i][j] ← sum}
ENDLOOP ENDLOOP;
END;
Identify: PUBLIC PROC[] =
-- replace all occurences of p by p.copy if p.copy # NIL.
{r, rr: PointPtr;
ScanLists[operation:move];
r ← pointLpad;
UNTIL r = pointRpad DO
IF r.link.copy # NIL THEN {rr ← r.link; r.link ← rr.link; GcPoint[rr]}
ELSE r ← r.link;
ENDLOOP};
MakeDefBody: PUBLIC PROC[orig, xaxis: PointPtr] RETURNS [REF]
= {IF xaxis = NIL THEN RETURN[OtherMakeDefBody[orig]] ELSE
{m[1][1] ← orig.x;
m[2][1] ← orig.y;
m[1][2] ← xaxis.x;
m[2][2] ← xaxis.y;
m1[1][1] ← 0;
m1[2][1] ← 0;
m1[1][2] ← 1;
m1[2][2] ← 0;
m[1][3] ← m[1][1] + m[2][1] - m[2][2];
m[2][3] ← m[2][1] + m[1][2] - m[1][1];
FOR j: INT IN [1..3] DO m[3][j] ← 1.0; m1[3][j] ← 1.0 ENDLOOP;
m1[1][3] ← m1[1][1] + m1[2][1] - m1[2][2];
m1[2][3] ← m1[2][1] + m1[1][2] - m1[1][1];
Invertm[];
IF singular THEN ERROR;
MultiplyMatrix[];
{p:PointPtr ← pointLpad.link;
WHILE p # pointRpad DO p.name ← NIL; p ← p.link ENDLOOP};
BuildLocalList[orig, xaxis];
BuildActionAndPredLists[];
{locals: REF ← IF localList = NIL THEN NIL ELSE Fix[localList, comma];
actions: REF ← IF actionList = NIL THEN $Skip ELSE Fix[actionList, semicolon];
preds: REF;
IF predList = NIL THEN preds ← $T ELSE preds ← Fix[predList, $and];
IF locals = NIL
THEN RETURN[actions]
ELSE
RETURN [LIST[$if, LIST[arrow, LIST[st, locals, preds], actions]]]}}};
OtherMakeDefBody: PROC[orig: PointPtr] RETURNS [REF] =
{p:PointPtr ← pointLpad.link;
WHILE p # pointRpad DO p.name ← NIL; p ← p.link ENDLOOP;
BuildLocalList[orig, NIL];
BuildActionAndPredLists[];
{locals: REF ← IF localList = NIL THEN NIL ELSE Fix[localList, comma];
actions: REF ← IF actionList = NIL THEN $Skip ELSE Fix[actionList, semicolon];
preds: REF;
IF predList = NIL THEN preds ← $T ELSE preds ← Fix[predList, $and];
IF locals = NIL
THEN RETURN[actions]
ELSE
RETURN [LIST[$if, LIST[arrow, LIST[st, locals, preds], actions]]]}};
arrow: ATOM = Atom.MakeAtom["->"];
st: ATOM = Atom.MakeAtom["|"];
comma: ATOM = Atom.MakeAtom[","];
semicolon: ATOM = Atom.MakeAtom[";"];
approx: ATOM = Atom.MakeAtom["=="];
leftpren: ATOM = Atom.MakeAtom["("];
Fix: PROC [rr: REF, op: REF] RETURNS [REF] =
{r: LIST OF REF ← NARROW[rr];
IF r.rest = NIL
THEN RETURN [r.first]
ELSE RETURN [LIST[op, r.first, Fix[r.rest, op]]]};
localList: LIST OF REF;
actionList: LIST OF REF;
predList: LIST OF REF;
BuildLocalList: PROC [orig, xaxis: PointPtr] =
{i: INT ← 2;
p: PointPtr ← pointLpad.slink;
x, y: REAL;
localList ← NIL;
UNTIL p = pointRpad DO
IF p = orig THEN p.name ← $a
ELSE IF p = xaxis THEN p.name ← $b
ELSE
{a: ATOM;
IF i > 25
THEN a ← Atom.MakeAtom[Rope.Cat["a", Convert.RopeFromInt[i - 26, 10, FALSE]]]
ELSE a ← Atom.MakeAtom[Rope.FromChar['a + i]];
p.name ← a;
i ← i + 1;
IF xaxis # NIL
THEN
{x ← p.x * m[1][1] + p.y * m[1][2] + m[1][3];
y ← p.x * m[2][1] + p.y * m[2][2] + m[2][3];
localList ← CONS[
LIST[approx, a, LIST[$rel, LIST[leftpren,
LIST[comma, NEW[REAL ← x], NEW[REAL ← y]]],
LIST[leftpren, LIST[comma, $a, $b]]]],
localList]}
ELSE
{x ← p.x - orig.x;
y ← p.y - orig.y;
localList ← CONS[
LIST[approx, a, LIST[$rel, LIST[leftpren,
LIST[comma, NEW[REAL ← x], NEW[REAL ← y]]],
LIST[leftpren, $a]]],
localList]}};
JunoGraphics.DrawRope[Atom.GetPName[NARROW[p.name]], p.x + 5, p.y + 5];
JunoGraphics.viewerChanged ← TRUE;
p ← p.slink
ENDLOOP};
BuildActionAndPredLists: PROC =
{actionList ← NIL;
predList ← NIL;
ScanLists[operation: build]};
copiedPoints: PUBLIC PointPtr;
Copy: PUBLIC PROCEDURE =
BEGIN
p, lastnew: PointPtr;
-- copy the list of selected points into a new list firstnew,
-- firstnew.slink ....
copiedPoints ← NewPoint[];
lastnew ← copiedPoints;
p ← pointLpad.slink;
p.copy ← copiedPoints;
copiedPoints.x ← p.x;
copiedPoints.y ← p.y;
copiedPoints.visible ← p.visible;
InsertPoint[copiedPoints];
p ← p.slink;
UNTIL p = pointRpad DO
lastnew.slink ← NewPoint[];
lastnew ← lastnew.slink;
p.copy ← lastnew;
lastnew.x ← p.x;
lastnew.y ← p.y;
copiedPoints.visible ← p.visible;
InsertPoint[lastnew];
p ← p.slink;
ENDLOOP;
lastnew.slink ← pointRpad;
ScanLists[operation: copy]; -- scan all edges, arcs, constraints and copy
-- any of them that involve copied points.
END;
ComputeTransform: PUBLIC PROC[a,b,c,sa,sb,sc:PointPtr] =
{-- we want m [ sa, sb, sc ] = [ a, b, c], where the points are viewed as
-- column vectors with third component 1. Hence we compute the inverse
-- of [sa, sb, sc] and multipy on the left by [a, b, c]. But the pairs
-- (b, sb), (c, sc) may be missing, in which case they are filled in by default to make
-- the transformation a translation (if both are missing) or a Euclidean motion
-- (if just (c, sc) is missing).
j: INTEGER;
FOR j IN [1..3] DO m[3][j] ← 1.0; m1[3][j] ← 1.0 ENDLOOP;
m[1][1] ← sa.x;
m[2][1] ← sa.y;
m1[1][1] ← a.x;
m1[2][1] ← a.y;
IF b # NIL AND sb # NIL THEN
{m[1][2] ← sb.x;
m[2][2] ← sb.y;
m1[1][2] ← b.x;
m1[2][2] ← b.y;}
ELSE
{m[1][2] ← sa.x + 300;
m[2][2] ← sa.y;
m1[1][2] ← a.x + 300;
m1[2][2] ← a.y};
IF c # NIL AND sc # NIL THEN
{m[1][3] ← sc.x;
m[2][3] ← sc.y;
m1[1][3] ← c.x;
m1[2][3] ← c.y}
ELSE
{m[1][3] ← m[1][1] + m[2][1] - m[2][2];
m[2][3] ← m[2][1] + m[1][2] - m[1][1];
m1[1][3] ← m1[1][1] + m1[2][1] - m1[2][2];
m1[2][3] ← m1[2][1] + m1[1][2] - m1[1][1]};
Invertm[];
IF singular THEN RETURN;
MultiplyMatrix[]}; -- end of ComputeTransform.
PerformTransform: PUBLIC PROCEDURE[p: PointPtr] =
{x, y: REAL;
UNTIL p = pointRpad DO
x ← p.x * m[1][1] + p.y * m[1][2] + m[1][3];
y ← p.x * m[2][1] + p.y * m[2][2] + m[2][3];
p.x ← x;
p.y ← y;
p ← p.slink;
ENDLOOP};
-- The move, copy and delete commands all involve scanning the lists of edges,
-- arcs, and constraints; this scan is done by one procedure (ScanLists) which
-- takes as an argument one of the four distinguished values copy, delete, move, mark:
Operation: TYPE = {copy, delete, move, mark, build};
AddAction: PROC[op: REF, r1: REF ← NIL, r2: REF ← NIL] =
{IF r2 = NIL
THEN actionList ← CONS[LIST[op, r1], actionList]
ELSE actionList ← CONS[LIST[op, r1, r2], actionList]};
Args: PROC [l: LIST OF PointPtr] RETURNS [REF] =
{IF l.rest = NIL
THEN RETURN [ArgName[l.first]]
ELSE RETURN [LIST[comma, ArgName[l.first], Args[l.rest]]]};
NewArgs: PROC [l: LIST OF REF] RETURNS [REF] =
{IF l.rest = NIL
THEN RETURN [ArgName[l.first]]
ELSE RETURN [LIST[comma, ArgName[l.first], NewArgs[l.rest]]]};
ArgName: PROC [r: REF] RETURNS [REF] =
{ WITH r SELECT FROM
rp: PointPtr => RETURN[rp.name];
ri: REF INT => RETURN[ri];
rr: Rope.ROPE => RETURN[rr];
ra: ATOM => RETURN[ra]
ENDCASE => ERROR };
PrenArgs: PROC [l: LIST OF PointPtr] RETURNS [REF] =
{RETURN [LIST[leftpren, Args[l]]]};
AddPred: PROC[op: REF, r1: REF ← NIL, r2: REF ← NIL] =
{IF r2 = NIL
THEN predList ← CONS[LIST[op, r1], predList]
ELSE predList ← CONS[LIST[op, r1, r2], predList]};
ScanLists: PROC[operation:Operation] =
BEGIN
{ -- scan the edges:
p: EdgePtr ← edgeLpad.link;
q: EdgePtr ← edgeLpad;
r: EdgePtr;
UNTIL p = edgeRpad DO
SELECT operation FROM
move => {IF p.b1.copy # NIL THEN p.b1 ← p.b1.copy;
IF p.b2.copy # NIL THEN p.b2 ← p.b2.copy;
p ← p.link};
copy => {IF p.b1.copy # NIL AND p.b2.copy # NIL
THEN {r ← NewEdge[];
r.b1 ← p.b1.copy; r.b2 ← p.b2.copy;
r.link ← edgeLpad.link; edgeLpad.link ← r};
p ← p.link};
delete => IF p.b1.copy # NIL AND p.b2.copy # NIL
THEN {q.link ← p.link; GcEdge[p]; p ← q.link}
ELSE {q ← p; p ← p.link};
mark => {p.b1.copy ← NIL; p.b2.copy ← NIL; p ← p.link};
build => {IF p.b1.name # NIL AND p.b2.name # NIL THEN
AddAction[$draw, PrenArgs[LIST[p.b1, p.b2]]];
p ← p.link}
ENDCASE => ERROR;
ENDLOOP};
{-- scan the arcs:
p: ArcPtr ← arcLpad.link;
q: ArcPtr ← arcLpad;
r: ArcPtr;
UNTIL p = arcRpad DO
SELECT operation FROM
move => {IF p.b1.copy # NIL THEN p.b1 ← p.b1.copy;
IF p.b2.copy # NIL THEN p.b2 ← p.b2.copy;
IF p.b3.copy # NIL THEN p.b3 ← p.b3.copy;
IF p.b4.copy # NIL THEN p.b4 ← p.b4.copy;
p ← p.link};
copy => {IF p.b1.copy # NIL AND p.b2.copy # NIL
AND p.b3.copy # NIL AND p.b4.copy # NIL
THEN {r ← NewArc[];
r.b1 ← p.b1.copy; r.b2 ← p.b2.copy;
r.b3 ← p.b3.copy; r.b4 ← p.b4.copy;
r.link ← arcLpad.link; arcLpad.link ← r};
p ← p.link};
delete => IF p.b1.copy # NIL AND p.b2.copy # NIL
AND p.b3.copy # NIL AND p.b4.copy # NIL
THEN {q.link ← p.link; GcArc[p]; p ← q.link}
ELSE {q ← p; p ← p.link};
mark => {p.b1.copy ← NIL; p.b2.copy ← NIL; p.b3.copy ← NIL; p.b4.copy ← NIL; p ← p.link};
build => {IF p.b1.name # NIL AND p.b2.name # NIL
AND p.b3.name # NIL AND p.b4.name # NIL
THEN AddAction[$draw, PrenArgs[LIST[p.b1, p.b2, p.b3, p.b4]]];
p ← p.link}
ENDCASE => ERROR;
ENDLOOP};
{ -- scan the strings:
p : StringPtr ← stringLpad.link;
q : StringPtr ← stringLpad;
r : StringPtr;
UNTIL p = stringRpad DO
SELECT operation FROM
move => {IF p.b3.copy # NIL THEN p.b3 ← p.b3.copy;
IF p.b4.copy # NIL THEN p.b4 ← p.b4.copy;
p ← p.link};
copy => {IF p.b3.copy # NIL AND p.b4.copy # NIL
THEN {r ← NewString[];
r.b3 ← p.b3.copy; r.b4 ← p.b4.copy;
r.stringText ← p.stringText;
r.fontName ← p.fontName;
r.fontSize ← p.fontSize;
r.bold ← p.bold;
r.italic ← p.italic;
r.height ← p.height; r.width ← p.width; r.depth ← p.depth;
r.link ← stringLpad.link; stringLpad.link ← r};
p ← p.link};
delete => IF p.b3.copy # NIL AND p.b4.copy # NIL
THEN {q.link ← p.link; GcString[p]; p ← q.link}
ELSE {q ← p; p ← p.link};
mark => {p.b3.copy ← NIL; p.b4.copy ← NIL;
p ← p.link };
build => {Pack: PROC[b, i: BOOL] RETURNS [r:INT] =
{r ← 0;
IF i THEN r ← r + 1;
IF b THEN r ← r + 2};
IF p.b3.name # NIL
THEN AddAction
[leftpren,
$print,
NewArgs[LIST[p.stringText,
p.b3,
Atom.MakeAtom[p.fontName],
NEW[INT ← p.fontSize],
NEW[INT ← Pack[p.bold, p.italic]]]]];
p ← p.link}
ENDCASE => ERROR;
ENDLOOP};
{ -- scan the horizontal constraints:
p: HorPtr ← horLpad.link;
q: HorPtr ← horLpad;
r: HorPtr;
UNTIL p = horRpad DO
SELECT operation FROM
move => {IF p.i.copy # NIL THEN p.i ← p.i.copy;
IF p.j.copy # NIL THEN p.j ← p.j.copy;
p ← p.link};
copy => {IF p.i.copy # NIL AND p.j.copy # NIL
THEN {r ← NewHor[];
r.i ← p.i.copy; r.j ← p.j.copy;
r.link ← horLpad.link; horLpad.link ← r};
p ← p.link};
delete => IF p.i.copy # NIL AND p.j.copy # NIL
THEN {q.link ← p.link; GcHor[p]; p ← q.link}
ELSE {q ← p; p ← p.link};
mark => {p.i.copy ← NIL; p.j.copy ← NIL; p ← p.link};
build => {IF p.i.name # NIL AND p.j.name # NIL
THEN AddPred[$hor, PrenArgs[LIST[p.i, p.j]]];
p ← p.link}
ENDCASE => ERROR;
ENDLOOP};
{ -- scan the vertical constraints:
p: VerPtr ← verLpad.link;
q: VerPtr ← verLpad;
r: VerPtr;
UNTIL p = verRpad DO
SELECT operation FROM
move => {IF p.i.copy # NIL THEN p.i ← p.i.copy;
IF p.j.copy # NIL THEN p.j ← p.j.copy;
p ← p.link};
copy => {IF p.i.copy # NIL AND p.j.copy # NIL
THEN {r ← NewVer[];
r.i ← p.i.copy; r.j ← p.j.copy;
r.link ← verLpad.link; verLpad.link ← r};
p ← p.link};
delete => IF p.i.copy # NIL AND p.j.copy # NIL
THEN {q.link ← p.link; GcVer[p]; p ← q.link}
ELSE {q ← p; p ← p.link};
mark => {p.i.copy ← NIL; p.j.copy ← NIL; p ← p.link};
build => {IF p.i.name # NIL AND p.j.name # NIL
THEN AddPred[$ver, PrenArgs[LIST[p.i, p.j]]];
p ← p.link}
ENDCASE => ERROR;
ENDLOOP};
{-- scan the congruence constraints:
p: CongPtr ← congLpad.link;
q: CongPtr ← congLpad;
r: CongPtr;
UNTIL p = congRpad DO
SELECT operation FROM
move => {IF p.i.copy # NIL THEN p.i ← p.i.copy;
IF p.j.copy # NIL THEN p.j ← p.j.copy;
IF p.k.copy # NIL THEN p.k ← p.k.copy;
IF p.l.copy # NIL THEN p.l ← p.l.copy;
p ← p.link};
copy => {IF p.i.copy # NIL AND p.j.copy # NIL
AND p.k.copy # NIL AND p.l.copy # NIL
THEN {r ← NewCong[];
r.i ← p.i.copy; r.j ← p.j.copy;
r.k ← p.k.copy; r.l ← p.l.copy;
r.link ← congLpad.link; congLpad.link ← r};
p ← p.link};
delete => IF p.i.copy # NIL AND p.j.copy # NIL
AND p.k.copy # NIL AND p.l.copy # NIL
THEN {q.link ← p.link; GcCong[p]; p ← q.link}
ELSE {q ← p; p ← p.link};
mark => {p.i.copy ← NIL; p.j.copy ← NIL; p.k.copy ← NIL; p.l.copy ← NIL; p ← p.link};
build => {IF p.i.name # NIL AND p.j.name # NIL
AND p.k.name # NIL AND p.l.name # NIL
THEN AddPred[$cong, PrenArgs[LIST[p.i, p.j]], PrenArgs[LIST[p.k, p.l]]];
p ← p.link}
ENDCASE => ERROR;
ENDLOOP};
{-- scan the line constraints:
p: LinPtr ← lineLpad.link;
q: LinPtr ← lineLpad;
r: LinPtr;
UNTIL p = lineRpad DO
SELECT operation FROM
move => {IF p.i.copy # NIL THEN p.i ← p.i.copy;
IF p.j.copy # NIL THEN p.j ← p.j.copy;
IF p.k.copy # NIL THEN p.k ← p.k.copy;
IF p.l.copy # NIL THEN p.l ← p.l.copy;
p ← p.link};
copy => {IF p.i.copy # NIL AND p.j.copy # NIL
AND p.k.copy # NIL AND p.l.copy # NIL
THEN {r ← NewLine[];
r.i ← p.i.copy; r.j ← p.j.copy;
r.k ← p.k.copy; r.l ← p.l.copy;
r.link ← lineLpad.link; lineLpad.link ← r};
p ← p.link};
delete => IF p.i.copy # NIL AND p.j.copy # NIL
AND p.k.copy # NIL AND p.l.copy # NIL
THEN {q.link ← p.link; GcLine[p]; p ← q.link}
ELSE {q ← p; p ← p.link};
mark => {p.i.copy ← NIL; p.j.copy ← NIL; p.k.copy ← NIL; p.l.copy ← NIL; p ← p.link};
build => {IF p.i.name # NIL AND p.j.name # NIL
AND p.k.name # NIL AND p.l.name # NIL
THEN AddPred[$para, PrenArgs[LIST[p.i, p.j]], PrenArgs[LIST[p.k, p.l]]];
p ← p.link}
ENDCASE => ERROR;
ENDLOOP};
{-- scan the counter-clockwise constraints:
p: CCPtr ← ccLpad.link;
q: CCPtr ← ccLpad;
r: CCPtr;
UNTIL p = ccRpad DO
SELECT operation FROM
move => {IF p.i.copy # NIL THEN p.i ← p.i.copy;
IF p.j.copy # NIL THEN p.j ← p.j.copy;
IF p.k.copy # NIL THEN p.k ← p.k.copy;
p ← p.link};
copy => {IF p.i.copy # NIL AND p.j.copy # NIL
AND p.k.copy # NIL
THEN {r ← NewCC[];
r.i ← p.i.copy; r.j ← p.j.copy;
r.k ← p.k.copy;
r.link ← ccLpad.link; ccLpad.link ← r};
p ← p.link};
delete => IF p.i.copy # NIL AND p.j.copy # NIL
AND p.k.copy # NIL
THEN {q.link ← p.link; GcCC[p]; p ← q.link}
ELSE {q ← p; p ← p.link};
mark => {p.i.copy ← NIL; p.j.copy ← NIL; p.k.copy ← NIL; p ← p.link};
ENDCASE => ERROR;
ENDLOOP};
{ -- scan the algebraic constructions
p: LIST OF ApplyRecord ← constructionList;
q: LIST OF PointPtr ← NIL;
r: LIST OF ApplyRecord ← NIL;
UNTIL p = NIL DO
SELECT operation FROM
move => {q ← p.first.args;
UNTIL q = NIL DO
IF q.first.copy # NIL
THEN q.first ← q.first.copy;
q ← q.rest
ENDLOOP;
p ← p.rest};
copy => {IF AllHaveCopies[p.first.args]
THEN AddX[p.first.f, ListOfCopies[p.first.args]];
p ← p.rest};
delete => {IF AllHaveCopies[p.first.args]
THEN {IF r = NIL THEN {constructionList ← constructionList.rest;
p ← p.rest}
ELSE {r.rest ← p.rest; p ← p.rest}}
ELSE {r ← p; p ← p.rest}};
mark => {SetCopiesToNil[p.first.args]; p ← p.rest};
build => {IF AllHaveNames[p.first.args]
THEN actionList
← CONS[LIST[leftpren, p.first.f, Args[p.first.args]],
actionList];
p ← p.rest}
ENDCASE => ERROR;
ENDLOOP}
END; -- finally.
AllHaveCopies: PROC[l: LIST OF PointPtr] RETURNS [BOOL] =
{RETURN [l = NIL OR l.first.copy # NIL AND AllHaveCopies[l.rest]]};
AllHaveNames: PROC[l: LIST OF PointPtr] RETURNS [BOOL] =
{RETURN [l = NIL OR l.first.name # NIL AND AllHaveNames[l.rest]]};
ListOfCopies: PROC [l: LIST OF PointPtr] RETURNS [LIST OF PointPtr] =
{IF l = NIL THEN RETURN [NIL];
RETURN [CONS[l.first.copy, ListOfCopies[l.rest]]]};
SetCopiesToNil: PROC [l: LIST OF PointPtr] =
{IF l # NIL THEN {l.first.copy ← NIL; SetCopiesToNil[l.rest]}};
Delete: PUBLIC PROCEDURE =
BEGIN
p: PointPtr ← pointLpad.slink;
UNTIL p = pointRpad DO p.copy ← p; p ← p.slink ENDLOOP;
ScanLists[delete];
ScanLists[mark];
DeleteOriginals[];
END;
DeleteOriginals: PROC[] =
BEGIN
p, q: PointPtr;
p ← pointLpad.link;
q ← pointLpad;
UNTIL p = pointRpad DO
IF p.copy = NIL THEN {q ← p; p ← p.link}
ELSE {p.copy ← NIL; q.link ← p.link; GcPoint[p]; p ← q.link};
ENDLOOP;
END;
END.