Written July, 1982 by Donna M. Auguste and Greg Nelson

Last Edited by: Gnelson, October 11, 1983 9:50 pm

BEGIN
N000: NumPtr = NEW [NumCell ← [val: 000, const: TRUE, int: TRUE]];
N064: NumPtr = NEW [NumCell ← [val: 064, const: TRUE, int: TRUE]];
N128: NumPtr = NEW [NumCell ← [val: 128, const: TRUE, int: TRUE]];
N192: NumPtr = NEW [NumCell ← [val: 192, const: TRUE, int: TRUE]];
N224: NumPtr = NEW [NumCell ← [val: 224, const: TRUE, int: TRUE]];
N255: NumPtr = NEW [NumCell ← [val: 255, const: TRUE, int: TRUE]];

RETURN [LIST[

-- color values
$black,   LIST [N000, N000, N000],
$white,   LIST [N255, N255, N255],
$grey,    LIST [N128, N128, N128],
$red,    LIST [N255, N000, N000],
$blue,    LIST [N000, N000, N255],
$green,   LIST [N000, N255, N000],
$darkred,   LIST [N192, N064, N000],
$darkblue,  LIST [N000, N064, N192],
$darkgreen,  LIST [N000, N192, N064],
$lightred,   LIST [N255, N128, N128],
$lightblue,  LIST [N128, N192, N255],
$lightgreen,  LIST [N192, N255, N128],
$yellow,   LIST [N255, N255, N000],
$cyan,    LIST [N000, N255, N255],
$magenta,   LIST [N255, N000, N255],
$darkyellow,  LIST [N224, N192, N000],
$darkcyan,  LIST [N000, N192, N192],
$darkmagenta, LIST [N192, N000, N192],
$lightyellow,  LIST [N255, N255, N128],
$lightcyan,  LIST [N128, N255, N255],
$lightmagenta, LIST [N255, N128, N255],

-- styles and fonts
$TimesRoman, "TimesRoman",
$Helvetica, "Helvetica",
$Gacha, "Gacha",
$roman, NEW[NumCell ← [val:0]],
$italic, NEW[NumCell ← [val:1]],
$bold, NEW[NumCell ← [val:2]],
$boldItalic, NEW[NumCell ← [val:3]]

-- stroke end types
$butt, $butt,
$square, $square,
$round, $round,

-- basic operators
comma, comma,
semicolon, semicolon,
plus, plus,
minus, minus,
times, times,
slash, slash,
div, div,
mod, mod,
paint, paint,
draw, draw,
fill, fill,
print, print,
leftPren, leftPren,
leftBrack, leftBrack,
assign, assign,
quote, quote,
blow, blow,
skip, skip,
size, size,
font, font,
style, style,
colon, colon,
if, if,
do, do,
list, list]]
END;

BEGIN
p: Alist ← globals;
WHILE p # NIL DO
IF p.first = name THEN
{p.rest.first ← value; RETURN};
p ← p.rest.rest
ENDLOOP;
globals ← InsertDef[name, value, globals]
END;

BEGIN

END;

BEGIN
-- Atoms normally evaluate to a single value, obtained from alist or globals.
-- However, the primitive atom skip evaluates to no value.
val: Se = GetDef[atom, alist, globals];
IF val = skip THEN results ← NIL
ELSE results ← LIST[val]
END;

BEGIN
-- Each element of elist is of the form (then (st <locals> <constaints>) <command>)
alts: LIST OF Se ← elist;
success, impossible: BOOL ← FALSE;
solution: Alist;
stNode: Se ← NIL; -- (st <locals> <constaints>)
choice: Se ← NIL; -- last alternative that wasn't success or impossible
choiceSol: Alist; -- solution corresponding to choice
WHILE alts # NIL AND NOT success DO
stNode ← Cadr[alts.first];
[success, impossible, solution] ← TryToSolve [stNode, alist];
IF NOT impossible THEN
{choice ← alts.first; choiceSol ← solution};
IF success OR alts.rest = NIL THEN -- about to finish
{IF choice = NIL THEN -- all alternatives returned impossible
{Gr.Blink["IF statement aborted!"];
results ← NIL}
ELSE
{results ← Eval [Caddr[choice], choiceSol]}};
alts ← alts.rest;
ENDLOOP
END;

BEGIN
-- Each element of f is of the form (then (st <locals> <constaints>) <command>)
alts: LIST OF Se;
success, impossible: BOOL ← FALSE;
solution: Alist;
stNode: Se ← NIL; -- (st <locals> <constaints>)
results ← NIL;
DO
alts ← elist;
UNTIL success OR alts = NIL DO
stNode ← Cadr[alts.first];
[success, impossible, solution] ← TryToSolve [stNode, alist];
IF success THEN
{results ← List.NConc [results, Eval [Caddr[alts.first], solution]]};
alts ← alts.rest
ENDLOOP;
IF NOT success THEN RETURN
ENDLOOP
END;

BEGIN
-- stNode is of the form (st <locals> <constraints>) or just <constraints>
localDecls, constrs: LIST OF Se ← NIL;
newCells: LIST OF NumPtr; -- variables (& point coords) to be adjusted by the solver
IF IsBinAppl[suchThat].fits THEN
{localDecls: LIST OF Se ← Unnest[Cadr[stNode], comma, NIL];
-- Create all local points (at hinted positions) and put them in front of the alist
[newCells, newAlist] ← CreateLocals [locals, alist];
constrs ← Unnest[Caddr[stNode], and, true]}
ELSE
{newAlist ← alist;
newCells ← NIL;
constrs ← Unnest[stNode, and, true]};

-- Solve the constraints for the local points
[success, impossible] ← Solv.Solve[newCells, constrs];
-- return
RETURN[success, impossible, newAlist]
END;

BEGIN
-- Each element of locals has the forms
-- (<approx> <name> <value>)
-- where <value> is some expression.
-- Acceptable <value>s are: NumPtr, RopePtr, atom, or list of acceptable values
-- (in other words, no FunPtrs!).
-- Now allows hints to be relative to previous hints. May Greg forgive me for this... [JS]
decls: LIST OF Se ← localDecls;
var, hint, hintVal: Se;
fits: BOOL;
newAlist ← alist;
newCells ← NIL;
UNTIL decls = NIL DO
[var, hint, fits] ← IsBinAppl[decls.first, approx];
IF NOT fits THEN ERROR;
[hintVal, newCells] ← CreateVariable[Eval[hint, newAlist], newCells];
newAlist ← CONS[var, CONS[hintVal, newAlist]];
decls ← decls.rest
ENDLOOP
END;

BEGIN
newCells ← prevCells;
IF val = NIL THEN
{cval ← NIL}
ELSE WITH val SELECT FROM
nn: NumPtr =>
{cval ← NEW [NumCell ← [val: nn.val, int: FALSE, const: FALSE]];
newCells ← CONS [cval, newCells]};
rr: RopePtr =>
{cval ← NEW [RopeCell ← [val: rr.val, const: FALSE]]};
aa: ATOM =>
{cval ← aa};
ll: LIST OF Se =>
{rval: LIST OF Se;
fval: Se;
[fval, newCells] ← CreateVariable[ll.first, newCells];
[rval, newCells] ← CreateVariable[ll.rest, newCells];
cval ← IF fval # ll.first OR rval#ll.rest THEN CONS [fval, rval] ELSE val};
ENDCASE => Gr.Error["invalid hint for local variable"]
END;

BEGIN
-- Sets a graphics parameter to a new value, saving the old one.

SELECT parm FROM

END;

BEGIN
-- Restores a graphics parameter to its old value.

SELECT parm FROM

END;

BEGIN
ss: INT = ToInt[s];
style.italic ← (ss MOD 2 # 0);
style.bold ← ((ss DIV 2) MOD 2 # 0);
END;

BEGIN
WITH w SELECT FROM
fr: NumPtr => RETURN [fr.val];
ff: LIST OF Value =>
{p, q: Coords;
CheckForm[w, pointPairMold];
p ← ToCoords [ff.first];
q ← ToCoords [ff.rest.first];
RETURN [Real.SqRt[(p.x - q.x) * (p.x - q.x) + (p.y - q.y) * (p.y - q.y)]]};
ENDCASE => ERROR
END;

BEGIN
ToByte: PROC[r: REF ANY] RETURNS [[0..256)] =
{RETURN[Real.RoundI[MAX[0.0, MIN[255.0, ToReal[r]]]]]};

triple: LIST OF Se ← ToList[c, 3, 3]];
RETURN
[[r: ToByte[triple.first],
g: ToByte[triple.rest.first],
b: ToByte[triple.rest.rest.first] ]]
END;

BEGIN
SELECT TRUE FROM
r = $butt => RETURN[butt];
r = $square => RETURN[square];
r = $round => RETURN[round]
ENDCASE => ERROR
END;

BEGIN
WITH function SELECT FROM
ff: ATOM =>
{results ← ApplyAtom[ff, args]};
ff: NumPtr =>
{<require length[args] = 1, n=ff.val to be integer;
fetch Cad^{n-1}r[args.first] or Cd^{-n}r[args.first], as appropriate>}
ff: FunPtr =>
{results ← ApplyFunVal [ff, args]};
ENDCASE =>
{Gr.Error["Invalid function"]; result ← NIL}
END;

BEGIN
WITH function SELECT FROM
ff: ATOM =>
{results ← ApplyBinaryAtom[ff, args]};
ff: FunPtr =>
{results ← ApplyFunVal [ff, largs];
IF results = NIL OR results.rest # NIL OR NOT ISTYPE[results.first, FunPtr]
THEN ERROR;
results 𡤊pplyFunVal [NARROW[results.first], rargs]};
ENDCASE =>
{Gr.Error["Invalid function"]; result ← NIL}
END;

BEGIN
SELECT function FROM

blow =>

minus =>

print =>

draw, stroke, fill =>

leftPren =>

leftBrack, list =>

ENDCASE =>

END;

BEGIN
SELECT op FROM

END;

BEGIN
newAlist: Alist = BindArgs !!! CATCH ERROR
[funVal.parms, args, funVal.alist];
results ← Eval[funVal.body, newAlist]
END;

{ee: LIST OF Se ← ToList[e, 2, 2];
IF ee.first = NIL OR NOT ISTYPE [ee.first, NumPtr] OR
ee.rest.first = NIL OR NOT ISTYPE [ee.rest.first, NumPtr] THEN
ERROR InvalidSe[e];
p.x ← NARROW[ee.first];
p.y ← NARROW[ee.rest.first]};

BEGIN
list: LIST OF Se ← ToList [e, 1, 3];
frame ← nullFrame;
frame.np ← 1;
frame.org ← ToNumPair[list.first];
list ← list.rest;
IF list # NIL THEN
{frame.np ← 2;
frame.hor ← NARROW[list.first];
list ← list.rest;
IF list # NIL THEN
{frame.np ← 3;
frame.ver ← NARROW[list.first]}}
END;

{WITH e SELECT FROM
en: NumPtr => RETURN[en.val]
ENDCASE => ERROR InvalidSe[e]};

{p: NumPair ← ToNumPair[e];
RETURN[p.x.val, p.y.val]};

BEGIN
IF m = NIL THEN m ← NEW [Matrix];
m^[1][3] ← frame.org.x;
m^[2][3] ← frame.org.y;
m^[3][3] ← 1;

IF frame.xP=NIL THEN
{m^[1][1] ← 300;
m^[2][1] ← 0}
ELSE
{m^[1][1] ← frame.xP.x-frame.org.x;
m^[2][1] ← frame.xP.y-frame.org.y};
m^[3][1] ← 0;
IF frame.yP=NIL THEN
{m^[1][2] ← -m^[2][1];
m^[2][2] ← m^[1][1]}
ELSE
{m^[1][2] ← frame.yP.x-frame.org.x;
m^[2][2] ← frame.yP.y-frame.org.y};
m^[3][2] ← 0;
RETURN[m]
END;

BEGIN
-- Inverts m^ into mInv^ by pivoting three times; or sets "singular" flag.
-- Uses work if not NIL, otherwise allocates new matrix for result.
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.
IF work = NIL THEN work ← NEW[Matrix];
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 RETURN[NIL, TRUE];
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 work^[c[i]][j] ← m^[i][c[j]] ENDLOOP ENDLOOP;
RETURN[work, FALSE]
END;

BEGIN
i, j, k: INTEGER;
sum: REAL;
IF mc = NIL THEN mc ← NEW [Matrix];
FOR i IN [1..3] DO FOR j IN [1..3] DO
sum ← 0.0;
FOR k IN [1..3] DO sum ← sum + ma^[i][k] * mb^[k][j] ENDLOOP;
mc^[i][j] ← sum
ENDLOOP ENDLOOP;
RETURN[mc]
END;

BEGIN
-- We want
-- mat * [ src.org, src.xP, src.yP ] = [ dest.org, dest.xP, dest.yP ],
-- where the points are viewed as
-- column vectors with third component 1. Hence we compute the inverse
-- of src and multipy on the left by dest. But the pairs
-- (dest.xP, src.xP), (dest.yP, src.yP) 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).
-- The matrix mm is optional, and is used to store the result: if NIL, a new one is allocated.
-- Uses m1, mInv as work areas.
sing: BOOL;
mm ← GetFrameMatrix[src, mm];
[mInv, sing] ← InvertMatrix[mm, mInv];
IF sing THEN RETURN [NIL, sing];
m1 ← GetFrameMatrix[dest, m1];
mm ← MultiplyMatrix[m1, mInv, mm];
RETURN [mm, sing]
END;

BEGIN
-- Similar to the above, except that tries simpler transforms (by dropping
-- last one or two pairs) if the given frames specify a aingular transformation.
[mat, singular] ← ComputeTransform [src, dest, mm];
IF singular THEN [mat, singular] ← ComputeTransform
[src: [src.org, src.xP, NIL], dest: [dest.org, dest.xP, NIL], mm: mat];
IF singular THEN [mat, singular] ← ComputeTransform
[src: [src.org, NIL, NIL], dest: [dest.org, NIL, NIL], mm: mat]
END;

BEGIN
-- Transforms x, y by the given matrix
xT ← x * mat^[1][1] + y * mat^[1][2] + mat^[1][3];
yT ← x * mat^[2][1] + y * mat^[2][2] + mat^[2][3]
END;