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