-- September 14, 1982 4:56 pm
--  program JunoAlgebraImplB.mesa
--  written July, 1982 by Donna M. Auguste and Greg Nelson

-- This part of Juno will take the user's algebraic description
-- of a figure (in the form of a ref any),
-- verify that the text is well-formed, and create a cursor
-- in the main juno viewer to allow the user to draw his
-- described figure there.
-- Last Edited by: Gnelson, October 11, 1983 9:50 pm

DIRECTORY     JunoStorage, JunoAlgebra, OldJunoSolver, List, 
                    JunoGraphics, Real, Rope, Atom;

JunoAlgebraImplB: PROGRAM
  IMPORTS  List, JunoGraphics, JunoStorage, OldJunoSolver, Atom, Real
  EXPORTS  JunoAlgebra = 
BEGIN  OPEN JS: JunoStorage, JG: JunoGraphics, JSolver: OldJunoSolver, JunoAlgebra;

leftPren: ATOM = Atom.MakeAtom["("];
colon: ATOM = Atom.MakeAtom[":"];
semicolon: ATOM = Atom.MakeAtom[";"];
comma: ATOM = Atom.MakeAtom[","];
assign: ATOM = Atom.MakeAtom[":="];
approx: ATOM = Atom.MakeAtom["=="];
minus: ATOM = Atom.MakeAtom["-"];
rightarrow: ATOM = Atom.MakeAtom["->"];
obox: ATOM = Atom.MakeAtom["//"];
suchthat: ATOM = Atom.MakeAtom["|"];


PointPtr: TYPE = JS.PointPtr;  

Length: PROC [l: REF ANY] RETURNS [INT] = {RETURN[List.Length[NARROW[l]]]};

Atomp: PROC [f: REF ANY] RETURNS [BOOL] = {RETURN[ISTYPE[f, ATOM]]};

Execute: PUBLIC PROC [f: REF ANY, alist: Se] = 
  {SELECT TRUE FROM
    
    Car[f] = semicolon => {Execute[Cadr[f], alist]; Execute[Caddr[f], alist]};
    
    Car[f] = assign => {a: LIST OF PointPtr _ EvArgList[Cadr[f], alist];
    					   b: LIST OF PointPtr _ EvArgList[Caddr[f], alist];
    					   WHILE a # NIL 
    					     DO a.first.x _ b.first.x; a.first.y _ b.first.y;  a _ a.rest;  b _ b.rest
    					     ENDLOOP};
            
    Car[f] = $if => ExecuteIf[Cadr[f], alist];
    
    Car[f] = $do => ExecuteDo[Cadr[f], alist];
    
    Car[f] = leftPren AND Cadr[f] # $print => Apply[Cadr[f], EvArgList[Caddr[f], alist], alist];
    
    Car[f] = $draw => {DrawPatch: PROC [a: Se] =
             			     {b: LIST OF PointPtr _ EvArgList[Cadr[a], alist];
             			      IF b.rest.rest = NIL 
             			      THEN JG.DrawEdge[b.first.x, b.first.y, b.rest.first.x, b.rest.first.y]
             			      ELSE JG.DrawArc[b.first.x, b.first.y, 
             			                            b.rest.first.x, b.rest.first.y,
             			                            b.rest.rest.first.x, b.rest.rest.first.y,
             			                            b.rest.rest.rest.first.x, b.rest.rest.rest.first.y]};
						    MapArgList[DrawPatch, Cadr[f], comma]};
						    
      Car[f] = $stroke  OR Car[f] = $fill
                        => {AddPatch: PROC[a: Se] =
      				        {b: LIST OF PointPtr _ EvArgList[Cadr[a], alist];
             			         IF b.rest.rest = NIL 
             			         THEN JG.EdgeStroke[b.first.x, b.first.y, b.rest.first.x, b.rest.first.y]
             			         ELSE JG.ArcStroke[b.first.x, b.first.y, 
             			                               b.rest.first.x, b.rest.first.y,
             			                               b.rest.rest.first.x, b.rest.rest.first.y,
             			                               b.rest.rest.rest.first.x, b.rest.rest.rest.first.y]};
             			     JG.BeginStroke[];
             			     MapArgList[AddPatch, Cadr[f], comma];
             			     IF Car[f] = $stroke THEN JG.DrawStroke[] ELSE JG.DrawArea};
    
    Car[f] = $paint => {JG.PushColor[Cadr[f]]; Execute[Caddr[f], alist]; JG.PopColor[]};
    
    Car[f] = $ends => {JG.PushEnds[Cadr[f]]; Execute[Caddr[f], alist]; JG.PopEnds[]};
    
    Car[f] = $width => {JG.PushWidth[WidthFromArgList[Cadr[f], alist]]; 
                           Execute[Caddr[f], alist]; 
                           JG.PopWidth[]};
    
    Car[f] = leftPren AND Cadr[f] = $print => 
     {-- f == print(text, pt, font, size, face)
      g: Se _ Unnest[Caddr[f], comma];
      -- g == [text pt font size face]
      r: Rope.ROPE _ NARROW[Car[g]];
      p: PointPtr _ Eval[Cadr[g], alist];
      font: ATOM _ NARROW[Caddr[g]];
      size: INT _ NARROW[Cadddr[g], REF INT]^;
      face: INT _ NARROW[Cadddr[Cdr[g]], REF INT]^;
      italic: BOOL = 2 * (face / 2) # face;
      foo: INT = (face - (SELECT italic FROM TRUE => 1, ENDCASE => 0)) / 2;
      bold: BOOL = 2 * (foo / 2) # foo;
      JG.DrawString[p.x, p.y, r, NIL, Atom.GetPName[font], size, bold, italic]}
     
   ENDCASE => ERROR};
  
 WidthFromArgList: PROC[f: Se, alist: Se] RETURNS [REAL] =
   {WITH f SELECT FROM
     fr: REF REAL => RETURN [fr^];
     fi: REF INT => RETURN [fi^];
     ff: LIST OF REF =>
   {b: LIST OF PointPtr _ EvArgList[ff, alist];
    x1: REAL = b.first.x;
    y1: REAL = b.first.y;
    x2: REAL = b.rest.first.x;
    y2: REAL = b.rest.first.y;
    RETURN [Real.SqRt[(x1 - x2) * (x1 - x2) + (y1 - y2) * (y1 - y2)]]}
    ENDCASE => ERROR};
   
Apply: PUBLIC PROC[commandName: Se, args: LIST OF PointPtr, alist: Se] =
  {f: Se = JS.GetBody[commandName];
   IF f = NIL THEN ERROR UndefinedCommand[NARROW[commandName]];
   Execute[f, BindArgs[Unnest[JS.GetLocals[commandName], comma], args, alist]]};
             
UndefinedCommand: ERROR [name: ATOM] = CODE;

BindArgs: PROC [formals: Se, actuals: LIST OF PointPtr, alist: Se] 
            RETURNS [LIST OF REF ANY] =
  {IF formals = NIL AND actuals = NIL 
   THEN RETURN[NARROW[alist]]
   ELSE RETURN[CONS[Car[formals], 
                     CONS[actuals.first,
                            BindArgs[Cdr[formals], actuals.rest, alist]]]]};
 
 MapArgList: PROC [p: PROC[Se], f: Se, infixOp: Se] =
   {IF Atomp[f] OR Car[f] # infixOp 
    THEN p[f] 
    ELSE {p[Cadr[f]]; MapArgList[p, Caddr[f], infixOp]}};
 
 EvArgList: PROC [l: Se, alist: Se] RETURNS [LIST OF PointPtr] =
   {IF Atomp[l] 
    THEN RETURN [CONS[Eval[l, alist], NIL]] 
     ELSE RETURN [CONS[Eval[Cadr[l], alist], EvArgList[Caddr[l], alist]]]};
 
 Eval: PROC [f: Se, alist: Se] RETURNS [PointPtr] =
   {IF ISTYPE[f, PointPtr] THEN RETURN[NARROW[f]] ELSE RETURN[Lookup[f, alist]]};
 
 Lookup: PROC[f: Se, alist: Se] RETURNS [PointPtr] =
   {IF alist = NIL THEN ERROR UnboundPointName[NARROW[f]];
    IF f = Car[alist] 
    THEN RETURN[NARROW[Cadr[alist]]] 
    ELSE RETURN [Lookup[f, Cddr[alist]]]};
   
   UnboundPointName: ERROR[name: ATOM] = CODE;
   
 Unnest: PROC[f: Se, a: Se] RETURNS [Se] = 
   {IF Atomic[f] OR Car[f] # a 
    THEN RETURN [CONS[f, NIL]]
    ELSE RETURN [CONS[Cadr[f], NARROW[Unnest[Caddr[f], a]]]]};
 
 Atomic: PROC [f: Se] RETURNS [BOOL] =
   {RETURN[ ~ ISTYPE[f, LIST OF REF ANY]]}; --! should return FALSE on any list type
 
 ExecuteIf: PROC [f, alist : Se] = {ExecuteIf2[Unnest[f, obox], alist]};
 
 ExecuteDo: PROC[f, alist : Se] = {ExecuteDo2[Unnest[f, obox], alist]};
 
 ExecuteIf2: PROC [f, alist: Se]  =
 {IF f = NIL 
  THEN JG.Blink["IF statement aborted"] 
  ELSE {solved: BOOL _ FALSE;
          solution: REF ANY _ alist;
          -- f is of the form ((then (st locals constaints) <command>) ... )
          stNode: Se = Cadr[Car[f]]; --  stNode == (st locals constraints)
          [solved, solution] _ TryToSolve[locals: Unnest[Cadr[stNode], comma], 
                                               constraints: Unnest[Caddr[stNode], $and], 
                                               alist: alist];
          IF solved THEN {Execute[Caddar[f], solution]; JS.PopState[]}
                      ELSE {JS.PopState[]; ExecuteIf2[Cdr[f], alist]}}};
                     
ExecuteDo2: PROC [f, alist: Se]  = {ExecuteDo3[f, f, alist]};

ExecuteDo3: PROC [f, orig, alist: Se]  =
{IF f = NIL
  THEN RETURN
  ELSE {solved: BOOL _ FALSE;
          solution: REF ANY _ alist;
          stNode: Se = Cadr[Car[f]];
          [solved, solution] _ TryToSolve[locals: Unnest[Cadr[stNode], comma], 
                                                constraints: Unnest[Caddr[stNode], $and], 
                                                alist: alist];
           IF solved THEN {Execute[Caddar[f], solution]; 
                                JS.PopState[];
                                ExecuteDo3[orig, orig, alist]}
                     ELSE {JS.PopState[]; ExecuteDo3[Cdr[f], orig, alist]}}};
                     
TryToSolve: PROC [locals, constraints: REF ANY, alist: REF ANY] 
                          RETURNS [solved:BOOL _ FALSE, solution: REF ANY] = 
 { i: INT _ 1;
   -- initialize solution to be alist 
   -- then add n new points (n = length of locals) to solution, initial coords (400,400)
   --  point pairs on solution are (l1 p1...ln pn), where l = local & p = new PointPtr
 JS.PushState[]; --  push the state of junostorage (save constraint LPad's, and reinitialize to empty)
 solution _ InitializeLocals[locals, alist];
  
    -- enumerate constraints (AddHor, AddVer, etc) 
   EnumConstraints[constraints, solution];
   -- now the state of JunoStorage reflects the current set of constraints only
   -- set the tempfixed field of each of the old points(on alist)
     i _ 1;
    UNTIL i > (Length[alist]/2)     -- remember alist has (name, pointptr, name, pointptr...)
      DO
         NARROW[List.NthElement[NARROW[alist],( i * 2)], PointPtr].tempfixed _ TRUE;
         i _ i + 1;
      ENDLOOP;
    -- solve
    solved _ JSolver.Solve[0.1];
    
    -- Now reset the tempfixed fields to FALSE
      i _ 1;
    UNTIL i > (Length[alist]/2)
       DO
         NARROW[List.NthElement[NARROW[alist], (i * 2)], PointPtr].tempfixed _ FALSE;
         i _ i + 1;
       ENDLOOP;
    -- return
    RETURN[solved,solution]  
          };  -- end of the TryToSolve PROC

InitializeLocals: PROC [l: REF ANY, alist: REF ANY] RETURNS [REF ANY] =
  -- l # NIL => Car[l] has the form (== pointvar (rel coordinates referencepoints)))
  {IF l = NIL 
   THEN RETURN [alist]
   ELSE RETURN [CONS[Cadr[Car[l]], CONS[InitPoint[Caddr[Car[l]], alist], NARROW[InitializeLocals[Cdr[l], alist]]]]]};
   
CoerceToReal: PROC[r: REF ANY] RETURNS [REAL] =
  {WITH r SELECT FROM
     ri: REF INT => RETURN[ri^];
     rr: REF REAL => RETURN[rr^];
     rl: LIST OF REF ANY => RETURN[- CoerceToReal[Cadr[r]]] 
   ENDCASE => ERROR};
   
InitPoint: PROC [rr: REF ANY, alist: REF ANY] RETURNS [PointPtr] =
  -- r has the form ($rel (leftpren numlist) (leftpren pointvarlist))
  {nl: REF ANY = Unnest[Cadr[Cadr[rr]], comma];
   x, y, newx, newy: REAL;
   pl: LIST OF PointPtr = EvArgList[Cadr[Caddr[rr]], alist];
   p: PointPtr = pl.first;
   q: PointPtr = IF pl.rest # NIL THEN pl.rest.first ELSE NIL;
   r: PointPtr = IF pl.rest # NIL AND pl.rest.rest # NIL THEN pl.rest.rest.first ELSE NIL;
   x _ CoerceToReal[Car[nl]];
   y _ CoerceToReal[Cadr[nl]];
   SELECT TRUE FROM
     q = NIL => {newx _ p.x + x; newy _ p.y + y};
     r = NIL => {newx _ p.x + (q.x - p.x) * x + (p.y - q.y) * y;
     			   newy _ p.y + (q.y - p.y) * x + (q.x - p.x) * y};
     TRUE => {newx _ p.x + (q.x - p.x) * x + (r.x - p.x) * y;
     			 newy _ p.y + (q.y - p.y) * x + (r.y - p.y) * y}
   ENDCASE => ERROR;
   RETURN JS.AddPoint[newx, newy]};
      
EnumConstraints: PROC [constraints: REF ANY, solution: REF ANY] =
  {WITH constraints SELECT FROM
     cl: LIST OF REF ANY =>
        -- cl is of the form ((hor ($( <nest of args>)) ...), or hor -> ver or cc; or 
        -- cl is of the form ((cong ($( <twoargs>) ($( <two args>)) ...) or cong -> para
        -- cl is of the form (T ...) -> skip the T
        IF Car[cl] = $T THEN EnumConstraints[Cdr[cl], solution] ELSE
       {IF Caar[cl] = $hor OR Caar[cl] = $ver OR Caar[cl] = $cc
        THEN {p: LIST OF PointPtr _ EvArgList[Cadr[Cadr[Car[cl]]], solution];
		         SELECT TRUE FROM
                  Caar[cl] = $hor => JS.AddHor[p.first, p.rest.first];
                  Caar[cl] = $ver => JS.AddVer[p.first, p.rest.first];
                  Caar[cl] = $cc => JS.AddCC[p.first, p.rest.first, p.rest.rest.first]
                 ENDCASE => ERROR}
          ELSE {p: LIST OF PointPtr _ EvArgList[Cadr[Cadr[Car[cl]]], solution];
          	      q: LIST OF PointPtr _ EvArgList[Cadr[Caddr[Car[cl]]], solution];
          	      SELECT TRUE FROM
                     Caar[cl] = $cong =>
            			JS.AddCong[p.first, p.rest.first, q.first, q.rest.first];
            	     Caar[cl] = $para =>
            	       JS.AddLin[p.first, p.rest.first, q.first, q.rest.first];  
            	  ENDCASE => ERROR};
        EnumConstraints[Cdr[cl], solution]}
      ENDCASE => RETURN};

Car: PROC [r: Se] RETURNS [Se] = {RETURN[NARROW[r, LIST OF REF ANY].first]};

Cdr: PROC [r: Se] RETURNS [Se] = {RETURN[NARROW[r, LIST OF REF ANY].rest]};

Cadr: PROC [r: Se] RETURNS [Se] = {RETURN[Car[Cdr[r]]]};

Caddr: PROC [r: Se] RETURNS [Se] = {RETURN[Car[Cdr[Cdr[r]]]]};

Cddr: PROC [r: Se] RETURNS [Se] = {RETURN[Cdr[Cdr[r]]]};

Caar: PROC [r: Se] RETURNS [Se] = {RETURN[Car[Car[r]]]};

Cadar: PROC [l: Se] RETURNS [Se] =
{ RETURN[ Car[ Cdr[ Car[ l ] ] ] ] };

Caddar: PROC [l: Se] RETURNS [Se] =
{ RETURN[ Car[ Cdr[ Cdr[ Car[ l ] ] ] ] ]   };

Cadddar: PROC [l: Se] RETURNS [Se] =
{ RETURN[ Car[ Cdr[ Cdr[ Cdr[ Car[ l ] ] ] ] ] ]  };

Cadddr: PROC [l: Se] RETURNS [Se] =
{ RETURN[ Car[ Cdr[ Cdr[ Cdr[ l ] ] ] ] ]  };

Caddddar: PROC [l: Se] RETURNS [Se] =
{ RETURN[ Car[ Cdr[ Cdr[ Cdr[ Cdr[ Car[ l ] ] ] ] ] ] ]   };

Cddar: PROC [l: Se] RETURNS [Se] =
{ RETURN[ Cdr[ Cdr[ Car[ l ] ] ] ]  };


END.


��%�J��J��J��E���3�4