-- 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.