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 15, 1984 7:30:36 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.
TO FIX: more operations: xcoord, ycoord, plus, minus, times, div, floor, dec, inc, first, rest, cons (infix), dist (infix).
TO FIX: accept a pair of coordinates everywhere a point is needed (create a detached point with fixed=true). In local declarations, fully evaluate hint. In constraints, fully evaluate arguments and coerce them to points.
DIRECTORY
JunoStorage USING
[Point, PointList, Coords, Frame, Item, ItemList, ItemArgs,
Cons, GcList, GcPoints, GcItems, NewPoint, InsertPoint,
NewItem, InsertItem, ItemKind, ConstrKind],
JunoAlgebra,
JunoUserEvents USING [Blink],
JunoMatrix USING [Matrix, GetFrameMatrix, MapCoords],
JunoOldSolver USING [Solve, Outcome],
JunoGraphics USING
[DrawEdge, DrawArc, AppendEdge, AppendArc, FillTrajectory, GcTrajectory,
SetColor, SetEnds, SetWidth, SetFontName, SetFontSize, SetFontFace, Color, Trajectory,
DrawRope, IntensityToColor, RGBToColor, black,
white, SetJustification],
JunoExpressions,
JunoGlobalAlist USING[GetDef],
List USING [Length],
Real USING [RoundI, SqRt, Fix],
Rope USING [ROPE],
Atom USING [GetPName];
- - - - 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 <point> <point>))
-- or (leftparen (comma <point> (comma <point> (comma <point> <point>))))
b: ValueList = EvArgList[Cadr[a], alist];
IF b.rest.rest =
NIL
THEN
{p: Coords = CoerceToCoords[b.first];
q: Coords = CoerceToCoords[b.rest.first];
SELECT op FROM
draw, stroke => {Gr.DrawEdge[p, q, FALSE]};
fill => {t ← Gr.AppendEdge[t, p, q]};
ENDCASE}
ELSE
{p: Coords = CoerceToCoords[b.first];
r: Coords = CoerceToCoords[b.rest.first];
s: Coords = CoerceToCoords[b.rest.rest.first];
q: Coords = CoerceToCoords[b.rest.rest.rest.first];
SELECT op FROM
draw, 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 ← Glob.GetDef[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:
PUBLIC 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],
$gray, 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 = CoerceToCoords[wl.first];
q: Coords = CoerceToCoords[wl.rest.first];
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.ItemList;
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.GcItems[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.ItemList] =
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
ExpandSimpleConstr:
PROC [cex: Se]
RETURNS [constr: Stor.Item] =
Expands one constraint into JunoStorage form.
The constraint cex is of the form
(<unary constraint> <args>) or
(<binary constraint> <left args> <right args>) or
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];
kind: Stor.ConstrKind ←
SELECT op
FROM
hor => hor,
ver => ver,
para => para,
perp => perp,
cong => cong,
at => at,
ccw => ccw,
ENDCASE => ERROR;
SELECT kind
FROM
hor, ver =>
{largs: Stor.ItemArgs = CoerceToPoints[Eval[cl.rest.first, alist, FALSE]];
constr ← Stor.NewItem[kind: kind, args: largs]};
para, cong, perp =>
{largs: Stor.ItemArgs = CoerceToPoints[Eval[cl.rest.first, alist, FALSE]];
rargs: Stor.ItemArgs = CoerceToPoints[Eval[cl.rest.rest.first, alist, FALSE]];
constr ← Stor.NewItem
[kind: kind, args: CONS[largs.first, CONS[largs.rest.first, rargs]]]};
at =>
{p: Point = CoerceToPoint[Eval[cl.rest.first, alist, FALSE]];
coords: Coords = CoerceToCoords[Eval[cl.rest.rest.first, alist, FALSE]];
constr ← Stor.NewItem
[kind: kind,
args: LIST [p, NEW [REAL ← coords.x], NEW [REAL ← coords.y]]]};
ccw =>
{largs: Stor.ItemArgs = CoerceToPoints[Eval[cl.rest.first, alist, FALSE]];
constr ← Stor.NewItem [kind: kind, args: largs]};
ENDCASE =>
{[] ← ERROR EvError["Invalid constraint: ", GetPName[op]]}
END;
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
{constr: Stor.Item;
IF Car[cex] = rel THEN
{constr ← ExpandSimpleConstr[Cadr[cex]];
constr.frame ← CoerceToFrame[Eval[Caddr[cex], alist, FALSE]]}
ELSE
{constr ← ExpandSimpleConstr[cex]};
constrs ← Stor.InsertItem [item: constr, 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 coordinates"]};
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;
CoerceToPoint:
PROC[r: Value]
RETURNS [p: Point] =
BEGIN
WITH r SELECT FROM
pp: Point => p ← pp;
list: LIST OF Value =>
{IF list.rest = NIL THEN
{p ← CoerceToPoint[list.first]}
ELSE
{coords: Coords ← CoerceToCoords[r];
p ← Stor.NewPoint[coords: coords, visible: FALSE];
p.fixed ← TRUE}};
ENDCASE => [] ← ERROR EvError["Point expected"]
END;
CoerceToPoints:
PROC[r: Value]
RETURNS [pl:
LIST
OF
REF
ANY] =
BEGIN
IF r = NIL THEN {RETURN[NIL]};
WITH r SELECT FROM
pp: Point => pl ← LIST[pp];
list: LIST OF Value =>
{IF list.rest = NIL THEN
{pl ← LIST[CoerceToPoint[list.first]]}
ELSE IF ISTYPE [list.first, REF INT] OR ISTYPE [list.first, REF REAL] THEN
{pl ← LIST[CoerceToPoint[list]]}
ELSE
{Crc: PROC [x: LIST OF Value] RETURNS [z: LIST OF REF ANY] =
{RETURN[IF x=NIL THEN NIL ELSE CONS
[CoerceToPoint[x.first], Crc[x.rest]]]};
pl ← Crc[list]}};
ENDCASE => [] ← ERROR EvError["Point list expected"]
END;
CoerceToFrame:
PROC[r: Value]
RETURNS [f: Frame] =
BEGIN
list: LIST OF REF ANY = CoerceToPoints[r];
f ← [NIL, NIL, NIL];
IF list = NIL THEN RETURN;
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];
IF list.rest.rest.rest # NIL THEN [] ← 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