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