JunoAlgebraImpl.mesa (ex JunoAlgebraImplB.mesa)
Written July, 1982 by Donna M. Auguste and Greg Nelson
Edited September 14, 1982 4:56 pm
Last Edited by: Gnelson, October 11, 1983 9:50 pm
Last Edited by: Stolfi June 6, 1984 4:18:17 am PDT
This module is concerned with the interpretation of Juno symbolic expressions. It defines the semantics of the Juno language.
THINGS TO FIX:.
TO FIX: Parser: check priority of $rel (must be greater than approx, but less than constraints).
TO FIX: Add more intrinsics?
TO FIX: Parser: justified, font, size, face as separate operators.
TO FIX: Body: handle state-pushing actions correctly. Note their nesting structure.
TO FIX: Parse window: make proc alist private. Should return lambda expressions.
DIRECTORY
JunoStorage USING
[Point, PointList, Coords, Frame, Constr, ConstrList,
Cons, GcList, GcPoints, GcConstrs, NewPoint, InsertPoint,
NewHor, NewVer, NewPara, NewPerp, NewCong, NewAt, NewCcw,
InsertConstr],
JunoAlgebra,
JunoUserEvents USING [Blink],
JunoMatrix USING [Matrix, GetFrameMatrix, MapCoords],
JunoOldSolver USING [Solve, Outcome],
List,
JunoGraphics USING
[DrawEdge, DrawArc, AppendEdge, AppendArc, FillTrajectory, GcTrajectory,
SetColor, SetEnds, SetWidth, SetFontName, SetFontSize, SetFontFace, Color, Trajectory,
DrawRope, IntensityToColor, RGBToColor, black,
white, SetJustification],
JunoProcViewer USING[GetCurrentDef],
Real USING [RoundI, SqRt],
Rope USING [ROPE],
Atom USING [GetPName, MakeAtom];
- - - - RESERVED ATOMS
Tokens that have special meaning for the Juno interpreter:
and: PUBLIC ATOM ← $and;
approx: PUBLIC ATOM ← Atom.MakeAtom["=="];
assign: PUBLIC ATOM ← Atom.MakeAtom[":="];
at: PUBLIC ATOM ← $at;
ccw: PUBLIC ATOM ← $ccw;
colon: PUBLIC ATOM ← Atom.MakeAtom[":"];
comma: PUBLIC ATOM ← Atom.MakeAtom[","];
cong: PUBLIC ATOM ← $cong;
dec: PUBLIC ATOM ← $dec;
do: PUBLIC ATOM ← $do;
draw: PUBLIC ATOM ← $draw;
ends: PUBLIC ATOM ← $ends;
fill: PUBLIC ATOM ← $fill;
font: PUBLIC ATOM ← $font;
hor: PUBLIC ATOM ← $hor;
if: PUBLIC ATOM ← $if;
inc: PUBLIC ATOM ← $inc;
justified: PUBLIC ATOM ← $justified;
lambda: PUBLIC ATOM ← Atom.MakeAtom[">>"];
leftPren: PUBLIC ATOM ← Atom.MakeAtom["("];
minus: PUBLIC ATOM ← Atom.MakeAtom["-"];
obox: PUBLIC ATOM ← Atom.MakeAtom["//"];
paint: PUBLIC ATOM ← $paint;
para: PUBLIC ATOM ← $para;
perp: PUBLIC ATOM ← $perp;
print: PUBLIC ATOM ← $print;
rel: PUBLIC ATOM ← $rel;
rightArrow: PUBLIC ATOM ← Atom.MakeAtom["->"];
semicolon: PUBLIC ATOM ← Atom.MakeAtom[";"];
size: PUBLIC ATOM ← $size;
skip: PUBLIC ATOM ← $skip;
stroke: PUBLIC ATOM ← $stroke;
face: PUBLIC ATOM ← $face;
suchThat: PUBLIC ATOM ← Atom.MakeAtom["|"];
true: PUBLIC ATOM ← $T;
ver: PUBLIC ATOM ← $ver;
width: PUBLIC ATOM ← $width;
- - - - EVAL
Eval:
PUBLIC
PROC [expr: Se, alist: AList, cmd:
BOOL ←
FALSE]
RETURNS [value: Value] =
BEGIN
IF expr=
NIL
THEN
{value ← NIL; RETURN};
WITH expr
SELECT
FROM
atom:
ATOM =>
{IF atom = skip THEN {value ← NIL; RETURN};
IF cmd THEN
{value ← EvalFunc[atom, alist];
IF Cadr[value] # NIL THEN
{value ← SIGNAL EvError[GetPName[atom], " requires arguments"]}
ELSE
{value ← Eval[Caddr[value], NIL, cmd]}}
ELSE
{value ← GetDef[atom, alist];
IF value = NIL THEN
{value ← SIGNAL EvError["Undefined variable: ", GetPName[atom]]}}};
rr:
REF
REAL =>
{Must[NOT cmd]; value ← rr};
ri:
REF
INT =>
{Must[NOT cmd]; value ← ri};
rope:
ROPE =>
{Must[NOT cmd]; value ← rope};
list:
LIST
OF Se =>
{atom: ATOM ← NARROW[list.first];
IF list.rest = NIL THEN -- empty matchfix (?)
{Must[NOT cmd];
value ← IF atom # leftPren
THEN SIGNAL EvError ["Missing operand(s) of ", GetPName[atom]]
ELSE NIL}
ELSE IF atom = comma THEN
{Must[NOT cmd]; value ← EvArgList[expr, alist]}
ELSE IF list.rest.rest = NIL THEN
{value ← EvalUnary[atom, list.rest.first, alist, cmd]}
ELSE
{value ← EvalBinary[atom, list.rest.first, list.rest.rest.first, alist, cmd]}};
ENDCASE =>
{value ← SIGNAL EvError["Invalid expression"]}
END;
EvError: PUBLIC SIGNAL [item1, item2, item3: ROPE ← NIL] RETURNS [value: Value] = CODE;
Must:
PROC [bool:
BOOL] =
{IF NOT bool THEN [] ← SIGNAL EvError ["Operation not valid in this context"]};
EvalUnary:
PROC [op:
ATOM, arg: Se, alist: AList, cmd:
BOOL]
RETURNS [value: Value] =
Evaluates an Se of the form (op <arg>).
In general, evaluates the argument and then applies op to it, but treats some ops (like $draw, $if, $do) in a special way.
Corresponds roughly to part of old Execute.
BEGIN
SELECT op
FROM
if =>
{value ← EvalIf[arg, alist, cmd]};
do =>
{Must[cmd]; value ← EvalDo[arg, alist]};
leftPren =>
{-- grouping parentheses
value ← Eval[arg, alist, cmd]};
draw, stroke, fill =>
{t: Gr.Trajectory ←
NIL;
HandlePiece:
PROC [a: Se] =
{
-- a is (leftPren (comma var var))
-- or (leftparen (comma var (comma var (comma var var))))
b: ValueList = EvArgList[Cadr[a], alist];
IF b.rest.rest =
NIL
THEN
{p: Coords = NARROW[b.first, Point].coords;
q: Coords = NARROW[b.rest.first, Point].coords;
SELECT op FROM
draw => {Gr.DrawEdge[p, q, TRUE]};
stroke => {Gr.DrawEdge[p, q, FALSE]};
fill => {t ← Gr.AppendEdge[t, p, q]};
ENDCASE}
ELSE
{p: Coords = NARROW[b.first, Point].coords;
r: Coords = NARROW[b.rest.first, Point].coords;
s: Coords = NARROW[b.rest.rest.first, Point].coords;
q: Coords = NARROW[b.rest.rest.rest.first, Point].coords;
SELECT op FROM
draw => {Gr.DrawArc[p, r, s, q, TRUE]};
stroke => {Gr.DrawArc[p, r, s, q, FALSE]};
fill => {t ← Gr.AppendArc[t, p, r, s, q]};
ENDCASE};
Stor.GcList[b]};
Must[cmd];
MapNest [arg, comma, HandlePiece];
IF op = fill THEN
{Gr.FillTrajectory[t]; Gr.GcTrajectory[t]}};
ENDCASE =>
{value ← ApplyUnaryOp [op: op, arg: Eval[arg, alist, FALSE], cmd: cmd]}
END;
EvalBinary:
PROC [op:
ATOM, larg, rarg: Se, alist: AList, cmd:
BOOL]
RETURNS [value: Value] =
Evaluates an Se of the form (<op> <larg> <rarg>).
In general, evaluates the arguments and then applies op to them, but treats some ops (like $paint, semicolon, comma, leftPren) in a special way.
Corresponds roughly to old Execute.
BEGIN
SELECT op
FROM
semicolon =>
{[] ← Eval[larg, alist, TRUE]; value ← Eval[rarg, alist, cmd]};
assign =>
{a: ValueList = EvArgList[larg, alist];
b: ValueList = EvArgList[rarg, alist];
AssignPoint:
PROC [p, q: Point] =
{p.coords ← q.coords};
al: ValueList ← a;
bl: ValueList ← b;
Must[cmd];
WHILE al # NIL DO
AssignPoint[NARROW[al.first], NARROW[bl.first]];
al ← al.rest; bl ← bl.rest
ENDLOOP;
Stor.GcList[a]; Stor.GcList[b];
value ← NIL};
leftPren =>
{-- matchfix parenthesis (function call)
args: ValueList = EvArgList[rarg, alist];
[] ← Apply[EvalFunc[NARROW[larg], alist], args];
Stor.GcList[args]};
paint =>
{old: Gr.Color = Gr.SetColor[EvalColor[larg, alist]];
value ← Eval[rarg, alist, cmd];
[] ← Gr.SetColor[old]};
ends =>
{old: ATOM = Gr.SetEnds[NARROW[larg]];
value ← Eval[rarg, alist, cmd];
[] ← Gr.SetEnds[old]};
width =>
{old: REAL = Gr.SetWidth[EvalWidth[larg, alist]];
value ← Eval[rarg, alist, cmd];
[] ← Gr.SetWidth[old]};
font =>
{old: ROPE = Gr.SetFontName[NARROW[Eval[larg, alist, FALSE]]];
value ← Eval[rarg, alist, cmd];
[] ← Gr.SetFontName[old]};
size =>
{old: REAL = Gr.SetFontSize[CoerceToReal[Eval[larg, alist]]];
value ← Eval[rarg, alist, cmd];
[] ← Gr.SetFontSize[old]};
face =>
{old: ATOM = Gr.SetFontFace[NARROW[larg]];
value ← Eval[rarg, alist];
[] ← Gr.SetFontFace[old]};
justified =>
{old: ATOM = Gr.SetJustification[NARROW[larg]];
value ← Eval[rarg, alist];
[] ← Gr.SetJustification[old]};
ENDCASE =>
{value ← ApplyBinaryOp
[op: op, larg: Eval[larg, alist, FALSE], rarg: Eval[rarg, alist, FALSE], cmd: cmd]}
END;
EvArgList:
PROC [expr: Se, alist: AList]
RETURNS [vlist:
LIST
OF Value] =
Unnests the commas in expr, evaluates the component expressions, and makes a list of the results.
The difference between calling Eval and EvArgList is that Eval will first remove any parenthesis enclosing expr, and, if the outermost operator is comma, will unnest the commas and make a list of the evaluated components; otherwise, it will evaluate expr and return its value without any extra list levels.
In contrast, EvArgList will always unnest the commas (before removing any parenteses) and make a list. It follows that the top level of the result of EvArgList (but not of Eval) can be safely reclaimed by Stor.GcList.
Therefore, the Juno expressions "a,b", "(a,b),c", "(a),(((b)))" will give the same result in both Eval and EvArgList: respectively LIST[a, b], LIST[LIST[a, b], c], and LIST[a, b].
The expressions "a", "(((a)))", "(a, b)" will give respectively a, a, LIST[a, b] under Eval, and LIST[a], LIST[a], LIST[LIST[a, b]] under EvArgList.
The syntax and semantics of comma is a bit confusing. I believe I have a better one, but it would be too radical a change to implement here. [JS]
BEGIN
elist: LIST OF Se ← UnNest[expr, comma];
vlist ← elist;
WHILE elist # NIL DO
elist.first ← Eval[elist.first, alist, FALSE];
elist ← elist.rest
ENDLOOP
END;
EvalVar:
PUBLIC
PROC[atom:
ATOM, alist: AList]
RETURNS [value: Se] =
If atom is on given alist, returns its value from there.
If not there, complains
Should look in proc file? this would allow pasing procedures as parameters.
BEGIN
value ← GetDef[atom, alist];
IF value = NIL THEN
{value ← SIGNAL EvError["Undefined variable: ", GetPName[atom]]}
END;
EvalFunc:
PUBLIC
PROC[atom:
ATOM, alist: AList]
RETURNS [value: Se] =
Looks for atom in the current proc file (usually returns lambda) .
Should look in current alist first? this would allow pasing procedures as parameters.
BEGIN
value ← PView.GetCurrentDef[atom];
IF value = NIL THEN
{value ← SIGNAL EvError["Undefined function: ", GetPName[atom]]}
ELSE IF NOT ISTYPE [value, LIST OF Se] OR Car[value] # lambda THEN
{value ← SIGNAL EvError["Invalid definition: ", GetPName[atom]]}
END;
colorAlist: AList ← InitColorAlist[];
Pairs identifiers with Gr.Color (not really Values, but...)
EvalColor:
PROC [expr: Se, alist: AList]
RETURNS [color: Gr.Color] =
The expr must evaluate to a real number (gray level, 0= white, 1=black), or to a list of up to three numbers, giving [red, green, blue].
BEGIN
w: Value;
Is it a reserved color name?
WITH expr SELECT FROM
atom: ATOM =>
{cr: REF ← GetDef[atom, colorAlist];
IF cr # NIL THEN RETURN[NARROW[cr]]}
ENDCASE;
Didn't find it - evaluate and coerce to color
w ← Eval[expr, alist, FALSE];
WITH w SELECT FROM
wr: REF REAL =>
{RETURN [Gr.IntensityToColor[wr^]]};
wi: REF INT =>
{RETURN [Gr.IntensityToColor[wi^]]};
wl: LIST OF Value =>
{ToByte: PROC[r: Value] RETURNS [REAL] =
{RETURN[Real.RoundI[MAX[0.0, MIN[255.0, CoerceToReal[r]]]]]};
red: REAL = CoerceToReal[wl.first];
green: REAL = IF wl.rest = NIL
THEN 0 ELSE CoerceToReal[wl.rest.first];
blue: REAL = IF wl.rest = NIL OR wl.rest.rest = NIL
THEN 0 ELSE CoerceToReal[wl.rest.rest.first];
RETURN [Gr.RGBToColor[red, green, blue]]}
ENDCASE =>
{[] ← SIGNAL EvError["Invalid color specification"];
RETURN [Gr.IntensityToColor[1]]}
END;
InitColorAlist:
PROC
RETURNS [AList] =
BEGIN
Nc: PROC [r, g, b: REAL] RETURNS [color: Gr.Color] = INLINE
{RETURN[Gr.RGBToColor[r, g, b]]};
RETURN [LIST[
-- color values
$black, Gr.black,
$white, Gr.white,
$grey, Gr.IntensityToColor[0.5],
$red, Nc[1.0, 0.0, 0.0],
$blue, Nc[0.0, 0.0, 1.0],
$green, Nc[0.0, 1.0, 0.0],
$darkRed, Nc[0.8, 0.3, 0.0],
$darkBlue, Nc[0.0, 0.3, 0.8],
$darkGreen, Nc[0.0, 0.8, 0.3],
$lightRed, Nc[1.0, 0.5, 0.5],
$lightBlue, Nc[0.5, 0.8, 1.0],
$lightGreen, Nc[0.8, 1.0, 0.5],
$yellow, Nc[1.0, 1.0, 0.0],
$cyan, Nc[0.0, 1.0, 1.0],
$magenta, Nc[1.0, 0.0, 1.0],
$darkYellow, Nc[0.9, 0.8, 0.0],
$darkCyan, Nc[0.0, 0.8, 0.8],
$darkMagenta, Nc[0.8, 0.0, 0.8],
$lightYellow, Nc[1.0, 1.0, 0.5],
$lightCyan, Nc[0.5, 1.0, 1.0],
$lightMagenta, Nc[1.0, 0.5, 1.0]
]]
END;
EvalWidth:
PROC [expr: Se, alist: AList]
RETURNS [width:
REAL] =
The expr must evaluate to either a number or a point pair. In the latter case, returns the distance between the two.
BEGIN
w: Value ← Eval[expr, alist, FALSE];
WITH w SELECT FROM
wr: REF REAL =>
{RETURN [wr^]};
wi: REF INT =>
{RETURN [wi^]};
wl: LIST OF Value =>
{p: Coords = NARROW[wl.first, Point].coords;
q: Coords = NARROW[wl.rest.first, Point].coords;
RETURN [Real.SqRt[(p.x - q.x) * (p.x - q.x) + (p.y - q.y) * (p.y - q.y)]]}
ENDCASE =>
{[] ← SIGNAL EvError["Invalid width specification"];
RETURN [1]}
END;
EvalIf:
PROC [expr: Se, alist: AList, cmd:
BOOL]
RETURNS [value: Value] =
The expr is a nest of alternatives separated by oboxes.
Each alternative is of the form (then (st <locals> <constaints>) <command>)
BEGIN
OPEN Stor;
alternatives: LIST OF Se = UnNest[expr, obox];
bestOutcome: Solv.Outcome ← false;
choice: Se ← NIL; -- last alternative whose outcome wasn't false
choiceSol: AList ← alist; -- solution corresponding to choice
choicePts: PointList ← [NIL, NIL]; -- points corresponding to choice
FOR alts:
LIST
OF Se ← alternatives, alts.rest
WHILE alts #
NIL
AND bestOutcome#true
DO
outcome: Solv.Outcome;
solution: AList;
points: PointList;
stNode: Se ← Cadr[alts.first]; -- (st <locals> <constaints>)
[outcome, solution, points] ← TryToSolve [stNode, alist];
IF outcome=false OR outcome<=bestOutcome THEN
{Stor.GcList[start: solution, lim: alist]; Stor.GcPoints[points.first]}
ELSE
{IF choice # NIL THEN -- reclaim best previous choice and replace it
{GcList[start: choiceSol, lim: alist]; Stor.GcPoints[choicePts.first]};
bestOutcome ← outcome; choice ← alts.first;
choiceSol ← solution; choicePts ← points}
ENDLOOP;
IF bestOutcome = false THEN
{Evs.Blink["IF statement aborted!"]; value ← NIL}
ELSE
{IF bestOutcome # true THEN Evs.Blink["IF statement didn't converge!"];
value ← Eval [Caddr[choice], choiceSol, cmd];
Stor.GcList[start: choiceSol, lim: alist]; Stor.GcPoints[choicePts.first]};
Stor.GcList [alternatives]
END;
EvalDo:
PROC [expr: Se, alist: AList]
RETURNS [value: Value] =
The expr is a nest of alternatives separated by oboxes.
Each alternative is of the form (then (st <locals> <constaints>) <command>)
BEGIN
OPEN Stor;
alternatives: LIST OF Se = UnNest[expr, obox];
bestOutcome: Solv.Outcome ← true;
WHILE bestOutcome = true
DO
bestOutcome ← false;
FOR alts:
LIST
OF Se ← alternatives, alts.rest
WHILE alts #
NIL
DO
outcome: Solv.Outcome;
solution: AList;
points: PointList;
stNode: Se ← Cadr[alts.first]; -- (st <locals> <constaints>)
[outcome, solution, points] ← TryToSolve [stNode, alist];
IF outcome=true THEN
{[] ← Eval [Caddr[alts.first], solution, TRUE]};
Stor.GcList[start: solution, lim: alist]; Stor.GcPoints[points.first];
IF outcome > bestOutcome THEN {bestOutcome ← outcome}
ENDLOOP;
IF bestOutcome=uncertain THEN
{Evs.Blink["IF statement didn't converge!"]};
ENDLOOP;
Stor.GcList [alternatives];
value ← NIL
END;
TryToSolve:
PROC [stNode: Se, alist: AList]
RETURNS [outcome: Solv.Outcome, newAlist: AList, newPoints: Stor.PointList] =
The stNode is of the form (st <locals> <constraints>) or just <constraints>
BEGIN
locals: LIST OF Se ← NIL;
constrs: Stor.ConstrList;
IF ISTYPE[stNode, LIST OF Se] AND Car[stNode] = suchThat THEN
{localDecls: LIST OF Se ← UnNest[Cadr[stNode], comma];
-- Create all local points (at hinted positions) and put them in front of the alist
[newPoints, newAlist] ← CreateLocals [localDecls, alist];
constrs ← UnNestConstrs[Caddr[stNode], newAlist];
Stor.GcList[localDecls]}
ELSE
{newAlist ← alist;
newPoints ← [NIL, NIL];
constrs ← UnNestConstrs[stNode, newAlist]};
-- Solve the constraints for the local points, and fix them
outcome ← Solv.Solve[constrs, 0.1];
FOR p: Point ← newPoints.first, p.link WHILE p # NIL DO p.fixed ← TRUE ENDLOOP;
Stor.GcConstrs[constrs.first]
END;
CreateLocals:
PROC [localDecls:
LIST
OF Se, alist: AList]
RETURNS [newPoints: Stor.PointList, newAlist: AList] =
Creates local Points, linked in a list, and prepends them to the alist.
Those are the Points the solver will try to adjust.
Each element of locals has the forms
(approx <name> <expr>) or just <name>
In this version, the <expr> must evaluate to a point or a pair of numeric values.
Now allows hints to be relative to previous hints. May Greg forgive me for this... [JS]
BEGIN
decls: LIST OF Se ← localDecls;
coords: Coords;
point: Point;
name: ATOM;
newAlist ← alist;
newPoints ← [NIL, NIL];
UNTIL decls = NIL DO
WITH decls.first SELECT FROM
atom: ATOM =>
{coords ← [0, 0]; name ← atom};
list: LIST OF Se =>
{IF list.first # approx THEN
{[] ← ERROR EvError["Invalid declaration"]};
coords ← EvalCoords[list.rest.rest.first, newAlist];
name ← NARROW[list.rest.first]};
ENDCASE =>
{[] ← ERROR EvError["Invalid declaration"]};
point ← Stor.NewPoint[coords: coords, visible: FALSE];
newAlist ← Stor.Cons[name, Stor.Cons[point, newAlist]];
newPoints ← Stor.InsertPoint[p: point, ant: newPoints.last, list: newPoints];
decls ← decls.rest
ENDLOOP
END;
EvalCoords:
PROC [expr: Se, alist: AList]
RETURNS [coords: Coords] =
Evaluates expr and coerces the result to a pair of real coordinates.
The expr must evaluate to a point or a pair of numbers (reals or integers).
Now calls Eval and CoerceToCoords, but should trap the common case (rel <coords> <frame>), to avoid allocation.
BEGIN
RETURN[CoerceToCoords[Eval[expr, alist, FALSE]]]
END;
EvalFrame:
PROC [expr: Se, alist: AList]
RETURNS [frame: Frame] =
Evaluates expr and coerces the result to a variable reference frame (zero to three points).
The expr must evaluate to a point or a list of two or three points.
Now calls Eval and CoerceToFrame, but should trap the common case (rel <coords> <frame>), to avoid allocation.
BEGIN
RETURN[CoerceToFrame[Eval[expr, alist, FALSE]]]
END;
UnNestConstrs:
PROC [cNest: Se, alist: AList]
RETURNS [constrs: Stor.ConstrList] =
cNest is a nest of constraints, separated by comma; or just the atom true.
Expands cNest into a list of constraints in a format acceptable to the solver.
BEGIN
ExpandConstr:
PROC [cex: Se]
RETURNS [constr: Stor.Constr] =
Expands one constriant into JunoStorage form.
The constraint cex is of the form
(<unary constraint> <args>) or
(<binary constraint> <left args> <right args>) or
($rel <constraint> <frame expression> )
where the args must evaluate to lists of points.
BEGIN
WITH cex
SELECT
FROM
cl:
LIST
OF
REF
ANY =>
BEGIN
op:
ATOM =
NARROW[cl.first];
SELECT op
FROM
hor =>
{largs: ValueList = NARROW[Eval[cl.rest.first, alist, FALSE]];
constr ← Stor.NewHor[i: NARROW[largs.first], j: NARROW[largs.rest.first]]};
ver =>
{largs: ValueList = NARROW[Eval[cl.rest.first, alist, FALSE]];
constr ← Stor.NewVer[i: NARROW[largs.first], j: NARROW[largs.rest.first]]};
para =>
{largs: ValueList = NARROW[Eval[cl.rest.first, alist, FALSE]];
rargs: ValueList = NARROW[Eval[cl.rest.rest.first, alist, FALSE]];
constr ← Stor.NewPara
[i: NARROW[largs.first], j: NARROW[largs.rest.first],
k: NARROW[rargs.first], l: NARROW[rargs.rest.first]]};
perp =>
{largs: ValueList = NARROW[Eval[cl.rest.first, alist, FALSE]];
rargs: ValueList = NARROW[Eval[cl.rest.rest.first, alist, FALSE]];
constr ← Stor.NewPerp
[i: NARROW[largs.first], j: NARROW[largs.rest.first],
k: NARROW[rargs.first], l: NARROW[rargs.rest.first]]};
cong =>
{largs: ValueList = NARROW[Eval[cl.rest.first, alist, FALSE]];
rargs: ValueList = NARROW[Eval[cl.rest.rest.first, alist, FALSE]];
constr ← Stor.NewCong
[i: NARROW[largs.first], j: NARROW[largs.rest.first],
k: NARROW[rargs.first], l: NARROW[rargs.rest.first]]};
at =>
{constr ← Stor.NewAt
[p: NARROW[Eval[cl.rest.first, alist, FALSE]],
coords: CoerceToCoords[Eval[cl.rest.rest.first, alist, FALSE]]]};
ccw =>
{largs: ValueList = NARROW[Eval[cl.rest.first, alist, FALSE]];
constr ← Stor.NewCcw
[i: NARROW[largs.first],
j: NARROW[largs.rest.first],
k: NARROW[largs.rest.rest.first]]};
rel =>
{constr ← ExpandConstr[cl.rest.first];
IF constr.frame = [NIL, NIL, NIL] THEN
constr.frame ← CoerceToFrame[Eval[cl.rest.rest.first, alist, FALSE]]
ELSE
{[] ← ERROR EvError ["Constraint with two frames"]}};
ENDCASE =>
{[] ← ERROR EvError["Invalid constraint: ", GetPName[op]]}
END;
atom:
ATOM =>
{[] ← ERROR EvError ["Invalid constraint: ", GetPName[atom]]};
ENDCASE =>
{[] ← ERROR EvError ["Invalid constraint"]};
END;
ProcessConstr:
PROC [cex: Se] =
Expands one constraint (if not $true) and appends it to constrs.
{IF cex # true THEN
{constrs ← Stor.InsertConstr [c: ExpandConstr[cex], ant: constrs.last, list: constrs]}};
constrs ← [NIL, NIL];
MapNest[cNest, and, ProcessConstr]
END;
- - - - MISCELLANEOUS SUPPORT ROUTINES
UnNest:
PROC [expr: Se, op:
ATOM]
RETURNS [list:
LIST
OF Se] =
Takes an expression of the form (op expr1 (op expr2 ... (op exprn-1 exprn)...)) that results from the parsing of "expr1 op expr2 op ... op exprn", and returns LIST[expr1, expr2, ... exprn].
If expr is not of the form (op ...), then takes n to be 1, and returns LIST[expr].
Does NOT expand (or otherwise look into) the exprs.
BEGIN
DoUnNest:
PROC [e: Se]
RETURNS [
LIST
OF Se] =
{er: LIST OF Se ← NIL;
WITH e SELECT FROM
list: LIST OF Se =>
{IF list # NIL AND list.first = op THEN
{e ← list.rest.first; er ← list}};
ENDCASE;
RETURN [Stor.Cons [e, IF er = NIL THEN NIL ELSE DoUnNest[er.rest.rest.first]]]};
RETURN[DoUnNest[expr]]
END;
MapNest:
PROC [expr: Se, op:
ATOM,
Proc:
PROC[Se]] =
The effect is the same as UnNesting expr, and applying Proc in sequence to the elements of the result, except that the list is not allocated and the Proc is assumed to return no value.
BEGIN
DoMapNest:
PROC [e: Se] =
{er: LIST OF Se;
WITH e SELECT FROM
list: LIST OF Se =>
{IF list # NIL AND list.first = op THEN
{e ← list.rest.first; er ← list}};
ENDCASE;
Proc[e]; IF er # NIL THEN DoMapNest[er.rest.rest.first]};
DoMapNest[expr]
END;
CoerceToCoords:
PROC [val: Value]
RETURNS [coords: Coords] =
Coerces the given value to a pair of coordinates.
The value must be either a point or a list of two numbers (REAL or INT).
BEGIN
WITH val SELECT FROM
pp: Point =>
{coords ← pp.coords};
list: LIST OF Value =>
{IF list=NIL OR list.rest=NIL OR list.rest.rest # NIL THEN
{[] ← ERROR EvError["Invalid point hint"]};
coords.x ← CoerceToReal[list.first];
coords.y ← CoerceToReal[list.rest.first]};
ENDCASE =>
{[] ← ERROR EvError["Invalid point hint"]}
END;
CoerceToReal:
PROC[r: Value]
RETURNS [real:
REAL] =
BEGIN
WITH r SELECT FROM
ri: REF INT => real ← ri^;
rr: REF REAL => real ← rr^;
ENDCASE => [] ← ERROR EvError["Number expected"]
END;
CoerceToFrame:
PROC[r: Value]
RETURNS [f: Frame] =
BEGIN
f ← [NIL, NIL, NIL];
WITH r SELECT FROM
pp: Point => {f.org ← pp};
list: LIST OF Value =>
{f.org ← NARROW [list.first];
IF list.rest = NIL THEN RETURN;
f.hor ← NARROW [list.rest.first];
IF list.rest.rest = NIL THEN RETURN;
f.ver ← NARROW [list.rest.rest.first]};
ENDCASE => [] ← ERROR EvError["Invalid frame"]
END;
Length: PROC [l: REF ANY] RETURNS [INT] = {RETURN[List.Length[NARROW[l]]]};
Atomp: PROC [f: REF ANY] RETURNS [BOOL] = {RETURN[ISTYPE[f, ATOM]]};
UndefinedCommand: ERROR [name: ATOM] = CODE;
UnboundPointName: ERROR[name: ATOM] = CODE;
Atomic:
PROC [f: Se]
RETURNS [
BOOL] =
{RETURN[ ~ ISTYPE[f, LIST OF REF ANY]]}; --! should return FALSE on any list type
Car: PUBLIC PROC [r: Se] RETURNS [Se] = {RETURN[NARROW[r, LIST OF REF ANY].first]};
Cdr: PUBLIC PROC [r: Se] RETURNS [Se] = {RETURN[NARROW[r, LIST OF REF ANY].rest]};
Cadr: PUBLIC PROC [r: Se] RETURNS [Se] = {RETURN[Car[Cdr[r]]]};
Caddr: PUBLIC PROC [r: Se] RETURNS [Se] = {RETURN[Car[Cdr[Cdr[r]]]]};
Cddr: PUBLIC PROC [r: Se] RETURNS [Se] = {RETURN[Cdr[Cdr[r]]]};
- - - - OLD JUNK
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 [Stor.Cons[Cadr[Car[l]], Stor.Cons[InitPoint[Caddr[Car[l]], alist], NARROW[InitializeLocals[Cdr[l], alist]]]]]};
InitPoint:
PROC [rr:
REF
ANY, alist:
REF
ANY]
RETURNS [Point] =
-- 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 Point = EvArgList[Cadr[Caddr[rr]], alist];
p: Point = pl.first;
q: Point = IF pl.rest # NIL THEN pl.rest.first ELSE NIL;
r: Point = 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 Stor.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 Point ← EvArgList[Cadr[Cadr[Car[cl]]], solution];
SELECT TRUE FROM
Caar[cl] = $hor => Stor.AddHor[p.first, p.rest.first];
Caar[cl] = $ver => Stor.AddVer[p.first, p.rest.first];
Caar[cl] = $cc => Stor.AddCC[p.first, p.rest.first, p.rest.rest.first]
ENDCASE => ERROR}
ELSE {p: LIST OF Point ← EvArgList[Cadr[Cadr[Car[cl]]], solution];
q: LIST OF Point ← EvArgList[Cadr[Caddr[Car[cl]]], solution];
SELECT TRUE FROM
Caar[cl] = $cong =>
Stor.AddCong[p.first, p.rest.first, q.first, q.rest.first];
Caar[cl] = $para =>
Stor.AddLin[p.first, p.rest.first, q.first, q.rest.first];
ENDCASE => ERROR};
EnumConstraints[Cdr[cl], solution]}
ENDCASE => RETURN};
Execute:
PUBLIC
PROC [f:
REF
ANY, alist: Se] =
{SELECT TRUE FROM
Car[f] = semicolon => {Execute[Cadr[f], GetPName[alist]; Execute[Caddr[f], alist]};
Car[f] = assign => {a: LIST OF Point ← EvArgList[Cadr[f], alist];
b: LIST OF Point ← 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 Point ← EvArgList[Cadr[a], alist];
IF b.rest.rest = NIL
THEN Gr.DrawEdge[b.first.x, b.first.y, b.rest.first.x, b.rest.first.y]
ELSE Gr.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 Point ← EvArgList[Cadr[a], alist];
IF b.rest.rest = NIL
THEN Gr.EdgeStroke[b.first.x, b.first.y, b.rest.first.x, b.rest.first.y]
ELSE Gr.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]};
Gr.BeginStroke[];
MapArgList[AddPatch, Cadr[f], comma];
IF Car[f] = $stroke THEN Gr.DrawStroke[] ELSE Gr.DrawArea};
Car[f] = $paint => {Gr.PushColor[Cadr[f]]; Execute[Caddr[f], alist]; Gr.PopColor[]};
Car[f] = $ends => {Gr.PushEnds[Cadr[f]]; Execute[Caddr[f], alist]; Gr.PopEnds[]};
Car[f] = $width => {Gr.PushWidth[WidthFromArgList[Cadr[f], alist]];
Execute[Caddr[f], alist];
Gr.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: Point ← 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;
Gr.DrawRope[p.x, p.y, r, NIL, Atomfont], size, bold, italic]}
ENDCASE => ERROR};
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 Point
Stor.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)], Point].tempfixed ← TRUE;
i ← i + 1;
ENDLOOP;
-- solve
solved ← Solv.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)], Point].tempfixed ← FALSE;
i ← i + 1;
ENDLOOP;
-- return
RETURN[solved,solution]
}; -- end of the TryToSolve PROC