-- COGDiagTest.mesa: Test of 2-D diagrams
-- last modified by Stolfi - October 12, 1982 12:25 am
-- To do: fix visibility of faces
-- To do: buffer the image in a bitmap
-- To do: shake is shaking too much
-- To Run: run COGAll; run COGDiagTest
DIRECTORY
IO USING [PutF, GetChar, real],
COGDebug USING [in, out],
Rope USING [ROPE],
COGRandom USING [Toss],
GraphicsColor USING [IntensityToColor],
Process USING [Ticks, MsecToTicks, Pause],
Graphics USING [SetColor, DrawArea, Path, NewPath],
Real USING [SqRt],
RealFns USING [SinDeg, CosDeg],
COGCart USING [],
COGSpace USING [Vector, Point, Dot, Sub, Mul, DoubleRot, NMirror, Length, XYRot, Transf],
COGDrawing USING
[Drawing, Object, PainterProc, MenuProc, MakeDrawing, Make, Add, GetWriteRights,
Change, Release, SetCP, DrawTo,
AddMenuAction, MoveTo, LineTo, DoPaintAll, AddPropertyButton, GetProp],
COGDiagram USING
[DEdge, ConnectVertices, MakeSphere, Sym, Org, Dest, Left, Right, Dual, ONext,
VisitProc, Traverse, AddVertex, CloseFace, MakeBridge, SetRight, EdgeSide, SetLeft];
COGDiagTest: PROGRAM
IMPORTS
IO, Real, RealFns, COGDebug, COGDrawing, COGDiagram, COGRandom, COGSpace,
Graphics, Process, GraphicsColor =
BEGIN
OPEN
Draw: COGDrawing, Cart: COGCart, Diag: COGDiagram, Bug: COGDebug, Rand: COGRandom,
Sp: COGSpace, Real, IO, Rope, GraphicsColor;
dr: Draw.Drawing = Draw.MakeDrawing["Banana", [min: [-2.0, -2.0], max: [2.0, 2.0]]];
rDg: REF Diag.DEdge = NEW [Diag.DEdge ←
Diag.MakeSphere [v: NEW [Sp.Point ← [0.0, 0.0, 0.0]], f: NIL]];
dgobj: Draw.Object ← Draw.Make [Painter: PaintSolid, parms: [data: rDg]];
Vertex: TYPE = REF Sp.Point; -- gives vertex coordinates
Face: TYPE = REF Sp.Vector; -- gives face normal
cos45: REAL = SqRt[0.5];
sqrt33: REAL = SqRt[3]/3.0;
xob: Sp.Vector ← [1, 0, 0]; -- points to the left of observer
yob: Sp.Vector ← [0, 1, 0]; -- points upwards observer
zob: Sp.Vector ← [0, 0, 1]; -- points from origin towards observer
light: Sp.Vector ← [sqrt33, sqrt33, sqrt33]; -- unit vector towards light source (in observer's coordsys)
dob: REAL ← 12.0; -- distance from origin to observer
aCos: REAL = 112.0/113.0; -- cosine of a small angle
aSin: REAL = 15.0/113.0; -- its sine
delay: Process.Ticks = Process.MsecToTicks[0];
Visible: PROC [fc: Sp.Point, fn: Sp.Vector] RETURNS [BOOL] =
{RETURN [Sp.Dot[fn, Sp.Sub[Sp.Mul[dob, zob], fc]] >= 0.0]};
PaintSolid: Draw.PainterProc =
TRUSTED
BEGIN
rDg:
REF Diag.DEdge ←
NARROW [parms.data];
path: Graphics.Path ← Graphics.NewPath[6]; -- work path for face
dg: Diag.DEdge =
IF Draw.GetProp[dr, $Dual] =
NIL
THEN rDg^
ELSE Diag.Dual[rDg^];
lite: Sp.Vector = Sp.Transf[light, xob, yob, zob];
-- light source direction in object's coordsys
PaintEdge: Diag.VisitProc = TRUSTED
{p: Vertex = NARROW [Diag.Org[e]];
q: Vertex = NARROW [Diag.Dest[e]];
f: Face = NARROW [Diag.Left[e]];
g: Face = NARROW [Diag.Right[e]];
-- The test below is only correct for the primal; for the dual, the face centers are not
-- f^ and g^. Also, the face normals will not be f^ and g^ unless the polyhedron is
-- regular.
IF p = NIL OR q = NIL OR
(f # NIL AND NOT Visible [p^, f^]
AND g # NIL AND NOT Visible [p^, g^]) THEN RETURN;
Graphics.SetColor [context, parms.color];
Draw.SetCP[context, sf, [Sp.Dot[p^, xob], Sp.Dot[p^, yob], (dob - Sp.Dot[p^, zob])/dob]];
Draw.DrawTo[context, sf, [Sp.Dot[q^, xob], Sp.Dot[q^, yob], (dob - Sp.Dot[q^, zob])/dob]]};
PaintFace: Diag.VisitProc = TRUSTED
{-- e is an edge of the dual diagram
n: Face = NARROW [Diag.Org[e]];
p: Vertex ← NARROW [Diag.Left[e]];
ea: Diag.DEdge ← e;
nl: REAL; -- dot product of light direction and face normal
IF n = NIL THEN RETURN;
IF NOT Visible [p^, n^] THEN RETURN;
nl ← Sp.Dot[lite, n^];
p ← NARROW [Diag.Left[ea], Vertex];
Draw.MoveTo[path, sf, [Sp.Dot[p^, xob], Sp.Dot[p^, yob], (dob - Sp.Dot[p^, zob])/dob]];
ea ← Diag.ONext[ea];
WHILE ea # e DO
IF NARROW[Diag.Org[ea], Face] # n THEN RETURN;
p ← NARROW [Diag.Left[ea], Vertex];
Draw.LineTo [path, sf,
[Sp.Dot[p^, xob], Sp.Dot[p^, yob], (dob - Sp.Dot[p^, zob])/dob]];
ea ← Diag.ONext[ea]
ENDLOOP;
Graphics.SetColor
[context, GraphicsColor.IntensityToColor
[0.2+ 0.8*(IF nl <= 0 THEN 0.0 ELSE nl/Sp.Length[n^]) ]];
Graphics.DrawArea[context, path];
-- Draw.DrawDot[context, sf, -- -- DEBUG --
-- [Sp.Dot[n^, xob], Sp.Dot[n^, yob], -- -- DEBUG --
-- (dob - Sp.Dot[n^, zob])/dob], 2, blue] -- -- DEBUG --
};
-- Draw.DrawDot[context, sf, [0, 0, 1], 3, red]; -- -- DEBUG --
[] ← Diag.Traverse [Diag.Dual [dg], PaintFace, NIL, vertices];
[] ← Diag.Traverse [dg, PaintEdge, NIL, oneWay]
END;
MakeDodecahedron:
PROC [dr: Draw.Drawing, rDg:
REF Diag.DEdge] =
BEGIN OPEN Diag, RealFns;
-- dodecahedron parameters
sin72: REAL = SinDeg[72];
cos72: REAL = CosDeg[72];
sin36: REAL = SinDeg[36];
cos36: REAL = CosDeg[36];
fRad: REAL = 1.0; -- face radius
eLen: REAL = 2.0*fRad*SinDeg[36]; -- edge length
fApo: REAL = fRad*cos36; -- face apothema
fDiag: REAL = 2.0*fRad*sin72; -- face diagonal
oRad: REAL = fDiag*SqRt[3]/2; -- radius of circumsphere
iRad: REAL = SqRt[oRad*oRad - fRad*fRad]; -- radius of insphere (half height)
mz: REAL = fRad*SinDeg[18]; -- z-coord of middle vertices
b: Sp.Point ← [fRad, 0, -iRad]; -- vertex of bottom face
m: Sp.Point ← [SqRt[oRad*oRad - mz*mz], 0, -mz]; -- vertex on middle ring adj to b
n: Sp.Vector ← Sp.NMirror [[0, 0, -iRad], [fApo, 0, iRad]]; -- face normal
c: Draw.Change ← Draw.GetWriteRights[dr];
Bug.out.PutF["\nDiagTest: n = [%g, %g, %g]", real[n.x], real[n.y], real[n.z]];
BEGIN ENABLE UNWIND => {Draw.Release[dr, c]};
vb, vm: Vertex;
fn, f0: Face;
s, thisSide, otherSide: EdgeSide;
es0, es1, em1: DEdge;
esa, esaa, ema, eb, es, em: DEdge;
vm ← NEW [Sp.Point ← m];
vb ← NEW [Sp.Point ← b];
fn ← f0 ← NEW [Sp.Vector ← n];
rDg^ ← es0 ← esa ← MakeBridge [vm, vb, NIL];
thisSide ← left; otherSide ← right;
FOR i: NAT IN [1..10] DO
m ← Sp.XYRot[m, cos36, sin36]; m.z ← -m.z; vm ← NEW [Sp.Point ← m];
b ← Sp.XYRot[b, cos36, sin36]; b.z ← -b.z; vb ← NEW [Sp.Point ← b];
IF i < 10 THEN
{em ← AddVertex [vm, Sym[esa], otherSide];
es ← AddVertex [vb, em, thisSide]}
ELSE
{em ← ConnectVertices [Sym[ema], em1];
es ← es0};
IF i = 1 THEN
{es1 ← es; em1 ← em}
ELSE
{eb ← CloseFace [es, Sym[esaa], fn, thisSide]};
IF i < 10 THEN
{n ← Sp.XYRot[n, cos36, sin36]; n.z ← -n.z; fn ← NEW [Sp.Vector ← n]}
ELSE
{fn ← f0};
esaa ← esa; esa ← es; ema ← em;
s ← thisSide; thisSide ← otherSide; otherSide ← s;
Draw.DoPaintAll[dr]; Process.Pause[delay]
ENDLOOP;
SetLeft [eb, NEW[Sp.Vector ← [0, 0, -iRad]]]; -- bottom face
Draw.DoPaintAll[dr]; Process.Pause[delay];
eb ← CloseFace [es1, Sym[esaa], fn, thisSide]; -- thisSide = left here
SetRight [eb, NEW[Sp.Vector ← [0, 0, +iRad]]]; -- top face
Draw.DoPaintAll[dr]; Process.Pause[delay];
Draw.Release [dr, c]
END
END;
ShakeBasis: Draw.MenuProc =
TRUSTED
BEGIN
-- fix it! - shaking to much.
cx, cy: REAL ← 1.0;
sx, sy, d: REAL ← 0.0;
shakeDelay: Process.Ticks = Process.MsecToTicks[0];
THROUGH [1..20) DO
cx ← cx + Rand.Toss [-0.1, 0.1];
sx ← sx + Rand.Toss [-0.1, 0.1];
d ← SqRt[cx*cx + sx*sx];
cx ← cx/d; sx ← sx/d;
[xob, zob] ← Sp.DoubleRot [xob, zob, cx, sx];
cy ← cy + Rand.Toss [-0.1, 0.1];
sy ← sy + Rand.Toss [-0.1, 0.1];
d ← SqRt[cy*cy + sy*sy];
cy ← cy/d; sy ← sy/d;
[yob, zob] ← Sp.DoubleRot [yob, zob, cy, sy];
Draw.DoPaintAll[dr];
Process.Pause[shakeDelay]
ENDLOOP
END;
RotateBasis: Draw.MenuProc =
TRUSTED
-- Rotates the object (actually, the observer and light source) in a specified direction by a small amount. Also repaints the object. To be called with access rights to dr = write
BEGIN
SELECT menuData FROM
$UDRot =>
{[yob, zob] ← Sp.DoubleRot [yob, zob, aCos, IF button = red THEN aSin ELSE -aSin]};
$LRRot =>
{[xob, zob] ← Sp.DoubleRot [xob, zob, aCos, IF button = red THEN aSin ELSE -aSin]}
ENDCASE => {};
Draw.DoPaintAll[dr]
END;
[zob, xob] ← Sp.DoubleRot [zob, xob, cos45, cos45];
[zob, yob] ← Sp.DoubleRot [zob, yob, aCos, aSin];
Bug.out.PutF["\nDiagTest starting: say something:"];
[] ← Bug.in.GetChar[];
Draw.Add [dr, dgobj, 3];
MakeDodecahedron [dr, rDg];
Draw.AddPropertyButton [dr, $Dual];
Draw.AddMenuAction [dr, "UDRot", RotateBasis, $UDRot, write];
Draw.AddMenuAction [dr, "LRRot", RotateBasis, $LRRot, write];
Draw.AddMenuAction [dr, "Shake", ShakeBasis, NIL, write];
END...
-- Future version: Rethink!