MODULE; IMPORT JunoConfig, Drawing, JunoPt, JunoRect, PSFont, JunoRsrc, View; IMPORT ExternalProc; IMPORT JunoScope; IMPORT JunoRT, RTVal, JunoValue, JunoArgs; IMPORT VBT, VBTExtras, Filter, PaintOp, Font, Path, Point, Rect, DblBufferVBT; IMPORT Atom, Rd, Wr, Fmt, Thread, Text, TextRefTbl, Time, Date; IMPORT Process, Pickle, Rsrc; FROM ExternalProc IMPORT Closure, Bind; FROM Stdio IMPORT stderr; <* FATAL Thread.Alerted *> EXCEPTION Error; (* internal error *) <* FATAL Error *> (* should never be raised *) CONST MaxCacheSize = 40; (* # of external procs replaced by StartToFile(). *) FindFontProc = "FindFontISO"; TYPE ToFileClosure = Closure BRANDED "PSImpl.ToFileClosure" OBJECT i: Impl END; CacheRec = RECORD slot: CARDINAL; proc: Closure; END; REVEAL View.PSImpl = Public BRANDED "View.PSImpl" OBJECT OVERRIDES init := Init END; Impl = ImplPublic BRANDED "PSImpl.Impl" OBJECT rt: View.Root; wr: Wr.T := NIL; extCnt: CARDINAL; page: CARDINAL; cache: ARRAY [0..MaxCacheSize - 1] OF CacheRec; OVERRIDES startToFile := StartToFile; prologue := Prologue; epilogue := Epilogue; endToFile := EndToFile; END; PSImpl
StartToFile replaces the external PostScript procedures that change the
PostScript state by ToFileClosure objects. For Impl i, the method
call i.startToFile(wr) sets i.wr to wr, i.extCnt to the number of
replaced external procedures, and stores the replaced procedures and the
slots from which they came in i.cache.
PROCEDUREInit (d: T; ch: Drawing.ChildPublic; root: View.Root): T = BEGIN d.root := root; EVAL View.T.init(d, ch); d.ps.path := NEW(Path.T); d.psStack := NEW(REF ARRAY OF State, 10); RETURN d END Init; CONST DefaultColor = Color{r := 0.0, g := 0.0, b := 0.0}; DefaultColorOp = PaintOp.Fg; DefaultTextColorOp = PaintOp.TransparentFg; DefaultWidth = 1.0; DefaultEndStyle = VBT.EndStyle.Butt; DefaultJointStyle = VBT.JoinStyle.Miter; DefaultWindingStyle = VBT.WindingCondition.NonZero; DefaultFaceName = "Times-Roman"; DefaultFontSize = 4; (* PS.Large *) VAR (* CONST *) fontTbl: TextRefTbl.T; metricTbl: TextRefTbl.T; defaultXFont: Font.T; (* cached copy of default X font *) defaultXFontPtSize: JunoValue.Real; (* cached value of it's point size *) defaultPSMetric: PSFont.Metric; (* cached metric of default font *) <* INLINE *> PROCEDUREResetPath (VAR (*INOUT*) ps: State) = BEGIN Path.Reset(ps.path); ps.moveto := FALSE END ResetPath; CONST PageWidth = 8.5 * 72.0; PageHeight = 11.0 * 72.0; HalfWidth = PageWidth / 2.0; HalfHeight = PageHeight / 2.0; PROCEDUREDefaultBBox (d: T): JunoRect.T = TYPE OrientBBox = ARRAY JunoConfig.Orientation OF JunoRect.T; CONST BBoxSW = OrientBBox{ JunoRect.T{0.0, PageWidth, PageHeight, 0.0}, (* Portrait *) JunoRect.T{0.0, PageHeight, PageWidth, 0.0}}; (* Landscape *) BBoxCenter = OrientBBox{ JunoRect.T{-HalfWidth, HalfWidth, HalfHeight, -HalfHeight}, JunoRect.T{-HalfHeight, HalfHeight, HalfWidth, -HalfWidth}}; BBox = ARRAY JunoConfig.Origin OF OrientBBox{BBoxCenter, BBoxSW}; VAR ch: Drawing.ChildPublic := Filter.Child(d); BEGIN RETURN BBox[ch.getOrigin(), JunoConfig.orientation] END DefaultBBox; PROCEDUREReset (d: T; <*UNUSED*> inExec := TRUE) = BEGIN WITH ps = d.ps DO ps.color := DefaultColor; ps.width := DefaultWidth; ps.end := DefaultEndStyle; ps.join := DefaultJointStyle; ps.wind := DefaultWindingStyle; ResetPath(ps); ps.face := DefaultFaceName; ps.size := DefaultFontSize; ps.ptSize := defaultXFontPtSize; ps.bbox := DefaultBBox(d); ps.colorOp := DefaultColorOp; ps.textColorOp := DefaultTextColorOp; ps.xFont := defaultXFont; ps.psMetric := defaultPSMetric END END Reset; VAR (*CONST*) PSAtom := Atom.FromText("PS"); Save := Atom.FromText("Save"); Restore := Atom.FromText("Restore"); NewPath := Atom.FromText("NewPath"); MoveTo := Atom.FromText("MoveTo"); LineTo := Atom.FromText("LineTo"); CurveTo := Atom.FromText("CurveTo"); Close := Atom.FromText("Close"); Stroke := Atom.FromText("Stroke"); Fill := Atom.FromText("Fill"); Type := Atom.FromText("Type"); SetWidth := Atom.FromText("SetWidth"); SetEnd := Atom.FromText("SetEndStyle"); SetJoin := Atom.FromText("SetJointStyle"); GetWidth := Atom.FromText("GetWidth"); GetEnd := Atom.FromText("GetEndStyle"); GetJoin := Atom.FromText("GetJointStyle"); SetColor := Atom.FromText("SetColor"); SetWind := Atom.FromText("SetWinding"); GetColor := Atom.FromText("GetColor"); GetWind := Atom.FromText("GetWinding"); SetFace := Atom.FromText("SetFontFace"); SetSize := Atom.FromText("SetFontSize"); SetFont := Atom.FromText("SetFont"); GetFace := Atom.FromText("GetFontFace"); GetSize := Atom.FromText("GetFontSize"); GetFont := Atom.FromText("GetFont"); GetPtSz := Atom.FromText("GetFontPtSize"); FontH := Atom.FromText("FontHeight"); StringW := Atom.FromText("StringWidth"); StringBB := Atom.FromText("StringBBox"); CurrPt := Atom.FromText("CurrentPoint"); CurrPath := Atom.FromText("CurrentPath"); SetBBox := Atom.FromText("SetBBox"); GetBBox := Atom.FromText("GetBBox"); ShowPage := Atom.FromText("ShowPage"); ResetSym := Atom.FromText("Reset"); SavePage := Atom.FromText("SavePage"); RestPage := Atom.FromText("RestorePage"); CONST ButtEndsVal = 0; RoundEndsVal = 1; SquareEndsVal = 2; MiterJointsVal = 0; RoundJointsVal = 1; BevelJointsVal = 2; NZWindingVal = 0; OddWindingVal = 1; PROCEDURENew (rt: View.Root): Impl = VAR scp := JunoScope.New(NIL, size := 24); res := NEW(Impl, rt := rt, public_scp := scp, scp := scp); BEGIN ExternalProc.SetupBind(PSAtom, scp, rt); Bind(Save, NEW(Closure, invoke := SaveProc), in := 0); Bind(Restore, NEW(Closure, invoke := RestoreProc), in := 0); Bind(NewPath, NEW(Closure, invoke := NewPathProc), in := 0); Bind(MoveTo, NEW(Closure, invoke := MoveToProc), in := 1); Bind(LineTo, NEW(Closure, invoke := LineToProc), in := 1); Bind(CurveTo, NEW(Closure, invoke := CurveToProc), in := 3); Bind(Close, NEW(Closure, invoke := CloseProc), in := 0); Bind(Fill, NEW(Closure, invoke := FillProc), in := 0); Bind(Stroke, NEW(Closure, invoke := StrokeProc), in := 0); Bind(Type, NEW(Closure, invoke := TypeProc), in := 2); Bind(SetWidth, NEW(Closure, invoke := SetWidthProc), in := 1); Bind(SetEnd, NEW(Closure, invoke := SetEndStyleProc), in := 1); Bind(SetJoin, NEW(Closure, invoke := SetJoinStyleProc), in := 1); Bind(SetColor, NEW(Closure, invoke := SetColorProc), in := 1); Bind(SetWind, NEW(Closure, invoke := SetWindingProc), in := 1); Bind(SetFace, NEW(Closure, invoke := SetFaceProc), in := 1); Bind(SetSize, NEW(Closure, invoke := SetSizeProc), in := 1); Bind(SetFont, NEW(Closure, invoke := SetFontProc), in := 2); Bind(SetBBox, NEW(Closure, invoke := SetBBoxProc), in := 2); Bind(ShowPage, NEW(Closure, invoke := ShowPageProc), in := 0); Bind(ResetSym, NEW(Closure, invoke := ResetProc), in := 0); Bind(SavePage, NEW(Closure, invoke := SavePageProc), in := 0); Bind(RestPage, NEW(Closure, invoke := RestorePageProc), in := 0); Bind(GetWidth, NEW(Closure, invoke := GetWidthProc), in := 0, out := 1); Bind(GetEnd, NEW(Closure, invoke := GetEndStyleProc), in := 0, out := 1); Bind(GetJoin, NEW(Closure, invoke := GetJoinStyleProc), in := 0, out := 1); Bind(GetColor, NEW(Closure, invoke := GetColorProc), in := 0, out := 1); Bind(GetWind, NEW(Closure, invoke := GetWindingProc), in := 0, out := 1); Bind(GetFace, NEW(Closure, invoke := GetFaceProc), in := 0, out := 1); Bind(GetSize, NEW(Closure, invoke := GetSizeProc), in := 0, out := 1); Bind(GetFont, NEW(Closure, invoke := GetFontProc), in := 0, out := 2); Bind(GetPtSz, NEW(Closure, invoke := GetPtSizeProc), in := 0, out := 1); Bind(FontH, NEW(Closure, invoke := FontHProc), in := 0, out := 2); Bind(StringW, NEW(Closure, invoke := StringWProc), in := 1, out := 1); Bind(StringBB, NEW(Closure, invoke := StringBBProc), in := 1, out := 1); Bind(CurrPt, NEW(Closure, invoke := CurrPtProc), in := 0, out := 1); Bind(CurrPath, NEW(Closure, invoke := CurrPathProc), in := 0, out := 1); Bind(GetBBox, NEW(Closure, invoke := GetBBoxProc), in := 0, out := 2); RETURN res END New; PROCEDUREStartToFile (impl: Impl; wr: Wr.T) =
An implementation of thestartToFilemethod of anImpl.
PROCEDURE Replace(name: Atom.T; cl: ToFileClosure) =
(* Store the current external procedure stored under "name" in "impl"'s
cache, replace it by "cl" in the external code table, and set the "rt"
and "i" fields of "cl". *)
VAR p: JunoScope.Proc := JunoScope.Lookup(impl.scp, name); BEGIN
WITH entry = impl.cache[impl.extCnt] DO
entry.slot := p.index;
entry.proc := JunoRT.ext_code_tbl[p.index];
cl.rt := entry.proc.rt
END;
cl.i := impl;
JunoRT.ext_code_tbl[p.index] := cl;
INC(impl.extCnt)
END Replace;
(* StartToFile *)
BEGIN
impl.wr := wr;
impl.extCnt := 0;
impl.page := 1;
Replace(Save, NEW(ToFileClosure, invoke := SaveProc2));
Replace(Restore, NEW(ToFileClosure, invoke := RestoreProc2));
Replace(NewPath, NEW(ToFileClosure, invoke := NewPathProc2));
Replace(MoveTo, NEW(ToFileClosure, invoke := MoveToProc2));
Replace(LineTo, NEW(ToFileClosure, invoke := LineToProc2));
Replace(CurveTo, NEW(ToFileClosure, invoke := CurveToProc2));
Replace(Close, NEW(ToFileClosure, invoke := CloseProc2));
Replace(Stroke, NEW(ToFileClosure, invoke := StrokeProc2));
Replace(Fill, NEW(ToFileClosure, invoke := FillProc2));
Replace(Type, NEW(ToFileClosure, invoke := TypeProc2));
Replace(SetWidth, NEW(ToFileClosure, invoke := SetWidthProc2));
Replace(SetEnd, NEW(ToFileClosure, invoke := SetEndStyleProc2));
Replace(SetJoin, NEW(ToFileClosure, invoke := SetJoinStyleProc2));
Replace(SetColor, NEW(ToFileClosure, invoke := SetColorProc2));
Replace(SetFace, NEW(ToFileClosure, invoke := SetFaceProc2));
Replace(SetSize, NEW(ToFileClosure, invoke := SetSizeProc2));
Replace(SetFont, NEW(ToFileClosure, invoke := SetFontProc2));
Replace(FontH, NEW(ToFileClosure, invoke := FontHProc2));
Replace(StringW, NEW(ToFileClosure, invoke := StringWProc2));
Replace(StringBB, NEW(ToFileClosure, invoke := StringBBProc2));
Replace(ShowPage, NEW(ToFileClosure, invoke := ShowPageProc2));
Replace(SavePage, NEW(ToFileClosure, invoke := SavePageProc2));
Replace(RestPage, NEW(ToFileClosure, invoke := RestorePageProc2));
END StartToFile;
PROCEDURE Prologue (impl: Impl) RAISES {Wr.Failure} =
BEGIN
<* ASSERT impl.wr # NIL *>
WriteHeader(impl.wr);
WritePrologue(impl.wr, impl.rt.currView);
WriteSetup(impl.wr, impl.rt.currView);
WritePageHeader(impl.wr, impl.page)
END Prologue;
PROCEDURE WriteHeader (wr: Wr.T) RAISES {Wr.Failure} =
BEGIN
Wr.PutText(wr, "%!PS-Adobe-3.0\n");
Wr.PutText(wr, "%%Creator: Juno-2\n");
Wr.PutText(wr, "%%Title: Juno.ps\n");
Wr.PutText(wr, "%%CreationDate: ");
WriteTime(wr, Time.Now());
Wr.PutText(wr, "\n%%BoundingBox: (atend)\n");
Wr.PutText(wr, "%%Pages: (atend)\n");
Wr.PutText(wr, "%%PageOrder: Ascend\n");
Wr.PutText(wr, "%%Orientation: "
& JunoConfig.OrientName[JunoConfig.orientation] & "\n");
Wr.PutText(wr, "%%EndComments\n");
END WriteHeader;
PROCEDURE WritePrologue (wr: Wr.T; d: T) RAISES {Wr.Failure} =
VAR ch: Drawing.ChildPublic := Filter.Child(d); BEGIN
Wr.PutText(wr, "\n%%BeginPrologue\n");
(* define "InitializeJunoPage" procedure *)
Wr.PutText(wr, "% InitializeJunoPage\n%\n");
Wr.PutText(wr, "% Sets the initial graphics state for a Juno page\n");
Wr.PutText(wr, "/InitializeJunoPage {\n ");
Wr.PutText(wr, Fmt.Real(DefaultColor.r)); Wr.PutChar(wr, ' ');
Wr.PutText(wr, Fmt.Real(DefaultColor.g)); Wr.PutChar(wr, ' ');
Wr.PutText(wr, Fmt.Real(DefaultColor.b));
Wr.PutText(wr, " setrgbcolor\n ");
Wr.PutText(wr, Fmt.Real(DefaultWidth));
Wr.PutText(wr, " setlinewidth\n ");
Wr.PutText(wr, Fmt.Int(EndMapInv[DefaultEndStyle]));
Wr.PutText(wr, " setlinecap\n ");
Wr.PutText(wr, Fmt.Int(JoinMapInv[DefaultJointStyle]));
Wr.PutText(wr, " setlinejoin\n ");
Wr.PutText(wr, "10.435 setmiterlimit\n ");
(* Wr.PutText(wr, "newpath\n "); *)
Wr.PutChar(wr, '/');
Wr.PutText(wr, DefaultFaceName);
WriteFindFont(wr);
Wr.PutText(wr, Fmt.Real(defaultXFontPtSize));
Wr.PutText(wr, " scalefont setfont\n ");
(* Translate and rotate if necessary, based on "ch.getOrigin()" and
"JunoConfig.orientation". The PostScript variables "xCenter" and
"yCenter" are set to the coordinate at the center of the page for use
by the "showerror.ps" code in case a run-time error needs to be
displayed. *)
CASE ch.getOrigin() OF
JunoConfig.Origin.Center =>
Wr.PutText(wr, Fmt.Real(HalfWidth)); Wr.PutChar(wr, ' ');
Wr.PutText(wr, Fmt.Real(HalfHeight)); Wr.PutChar(wr, ' ');
Wr.PutText(wr, "translate\n")
| JunoConfig.Origin.SW =>
IF JunoConfig.orientation = JunoConfig.Orientation.Landscape THEN
Wr.PutText(wr, Fmt.Real(PageWidth));
Wr.PutText(wr, " 0 translate\n")
END
END;
IF JunoConfig.orientation = JunoConfig.Orientation.Landscape THEN
Wr.PutText(wr, " 90 rotate\n");
END;
Wr.PutText(wr, "} def\n\n");
(* copy "prologue.ps" file *)
<* FATAL Rd.Failure, Rd.EndOfFile, Thread.Alerted, Rsrc.NotFound *>
VAR rd: Rd.T := Rsrc.Open("prologue.ps", JunoRsrc.Path); BEGIN
(* copy PostScript code to "wr" *)
WHILE NOT Rd.EOF(rd) DO Wr.PutChar(wr, Rd.GetChar(rd)) END;
Rd.Close(rd)
END;
Wr.PutText(wr, "%%EndPrologue\n")
END WritePrologue;
PROCEDURE WriteTime (wr: Wr.T; t: Time.T) RAISES {Wr.Failure} =
Writes the timettowrin the form:"Wed, Jun 22, 11:19:40 PDT, 1994".
CONST
MonthName = ARRAY OF TEXT{
"Jan", "Feb", "Mar", "Apr", "May", "Jun",
"Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
DayName = ARRAY OF TEXT{
"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
VAR d: Date.T := Date.FromTime(t); BEGIN
Wr.PutText(wr, DayName[ORD(d.weekDay)]); Wr.PutText(wr, ", ");
Wr.PutText(wr, MonthName[ORD(d.month)]); Wr.PutChar(wr, ' ');
Wr.PutText(wr, Fmt.Int(d.day)); Wr.PutText(wr, ", ");
Wr.PutText(wr, Fmt.Int(d.hour)); Wr.PutChar(wr, ':');
Wr.PutText(wr, Fmt.Int(d.minute)); Wr.PutChar(wr, ':');
Wr.PutText(wr, Fmt.Int(d.second)); Wr.PutChar(wr, ' ');
Wr.PutText(wr, d.zone); Wr.PutText(wr, ", ");
Wr.PutText(wr, Fmt.Int(d.year))
END WriteTime;
PROCEDURE WriteFindFont (wr: Wr.T) RAISES {Wr.Failure} =
Writes the name of thefindfontprocedure towrsurrounded by space characters.
BEGIN
Wr.PutChar(wr, ' ');
Wr.PutText(wr, FindFontProc);
Wr.PutChar(wr, ' ')
END WriteFindFont;
PROCEDURE WriteSetup (wr: Wr.T; d: T) RAISES {Wr.Failure} =
VAR ch: Drawing.ChildPublic := Filter.Child(d); dx, dy := 0.0; BEGIN
Wr.PutText(wr, "\n%%BeginSetup\n");
Wr.PutText(wr, "% define the coordinates of the center of the page\n");
IF ch.getOrigin() = JunoConfig.Origin.SW THEN
CASE JunoConfig.orientation OF
JunoConfig.Orientation.Portrait => dx := HalfWidth; dy := HalfHeight
| JunoConfig.Orientation.Landscape => dx := HalfHeight; dy := HalfWidth
END
END;
Wr.PutText(wr, "/xCenter " & Fmt.Real(dx) & " def ");
Wr.PutText(wr, "/yCenter " & Fmt.Real(dy) & " def\n");
Wr.PutText(wr, "%%EndSetup\n")
END WriteSetup;
PROCEDURE WritePageHeader (wr: Wr.T; pageNum: CARDINAL) RAISES {Wr.Failure} =
VAR pg := Fmt.Int(pageNum); BEGIN
Wr.PutText(wr, "\n%%Page: ");
Wr.PutText(wr, pg); Wr.PutChar(wr, ' '); Wr.PutText(wr, pg);
Wr.PutText(wr, "\nsave\n");
Wr.PutText(wr, "InitializeJunoPage\n")
END WritePageHeader;
PROCEDURE WritePageTrailer (wr: Wr.T) RAISES {Wr.Failure} =
Invoked at the end of each page; brackets thesavedone inWritePageHeader.
BEGIN
Wr.PutText(wr, "restore\n");
END WritePageTrailer;
PROCEDURE Epilogue (impl: Impl; showPage := FALSE) RAISES {Wr.Failure} =
An implementation of theendToFilemethod of anImpl.
VAR
d := impl.rt.currView;
ch: Drawing.ChildPublic := Filter.Child(d);
BEGIN
<* ASSERT impl.wr # NIL *>
WritePageTrailer(impl.wr);
IF showPage THEN Wr.PutText(impl.wr, "showpage\n") END;
Wr.PutText(impl.wr, "\n%%Trailer\n");
Wr.PutText(impl.wr, "%%BoundingBox: ");
VAR bbox := d.ps.bbox; BEGIN
(* rotate if in "JunoConfig.Orientation.Landscape" *)
IF JunoConfig.orientation = JunoConfig.Orientation.Landscape THEN
IF ch.getOrigin() = JunoConfig.Origin.SW THEN
(* translate to portrait-page origin *)
bbox := JunoRect.Add(bbox, JunoPt.T{0.0, -PageWidth})
END;
bbox := JunoRect.Rotate90(bbox);
END;
(* translate if at "Origin.Center" *)
IF ch.getOrigin() = JunoConfig.Origin.Center THEN
bbox := JunoRect.Add(bbox, JunoPt.T{HalfWidth, HalfHeight})
END;
WriteRect(impl.wr, bbox)
END;
Wr.PutText(impl.wr, "\n%%Pages: ");
Wr.PutText(impl.wr, Fmt.Int(impl.page));
Wr.PutText(impl.wr, "\n%%EOF\n")
END Epilogue;
PROCEDURE EndToFile (impl: Impl) =
BEGIN
<* ASSERT impl.wr # NIL *>
FOR i := FIRST(impl.cache) TO impl.extCnt - 1 DO
JunoRT.ext_code_tbl[impl.cache[i].slot] := impl.cache[i].proc
END;
impl.wr := NIL
END EndToFile;
PROCEDURE CopyState (READONLY from: State; VAR (*OUT*) to: State) =
BEGIN
to := from;
to.path := Path.Copy(from.path);
END CopyState;
PROCEDURE SaveProc (dc: Closure): BOOLEAN =
VAR d := dc.rt.currView; BEGIN
IF d.sp > LAST(d.psStack^) THEN
VAR new := NEW(REF ARRAY OF State, 2 * NUMBER(d.psStack^)); BEGIN
SUBARRAY(new^, 0, NUMBER(d.psStack^)) := d.psStack^;
d.psStack := new
END
END;
CopyState(d.ps, d.psStack[d.sp]);
INC(d.sp);
RETURN TRUE
END SaveProc;
PROCEDURE SaveProc2 (cl: ToFileClosure): BOOLEAN =
BEGIN
IF NOT SaveProc(cl) THEN RETURN FALSE END;
TRY Wr.PutText(cl.i.wr, "gsave\n") EXCEPT
Wr.Failure => RETURN FALSE
END;
RETURN TRUE
END SaveProc2;
PROCEDURE RestoreProc (dc: Closure): BOOLEAN =
VAR d := dc.rt.currView; BEGIN
IF d.sp = 0 THEN RETURN FALSE END;
DEC(d.sp);
d.ps := d.psStack[d.sp];
RETURN TRUE
END RestoreProc;
PROCEDURE RestoreProc2 (cl: ToFileClosure): BOOLEAN =
BEGIN
IF NOT RestoreProc(cl) THEN RETURN FALSE END;
TRY Wr.PutText(cl.i.wr, "grestore\n") EXCEPT
Wr.Failure => RETURN FALSE
END;
RETURN TRUE
END RestoreProc2;
<* INLINE *>
PROCEDURE WritePoint (wr: Wr.T; READONLY pt: JunoPt.T) RAISES {Wr.Failure} =
BEGIN
Wr.PutText(wr, Fmt.Real(pt.x)); Wr.PutChar(wr, ' ');
Wr.PutText(wr, Fmt.Real(pt.y)); Wr.PutChar(wr, ' ')
END WritePoint;
<* INLINE *>
PROCEDURE WriteRect (wr: Wr.T; READONLY rect: JunoRect.T) RAISES {Wr.Failure} =
BEGIN
Wr.PutText(wr, Fmt.Real(rect.west)); Wr.PutChar(wr, ' ');
Wr.PutText(wr, Fmt.Real(rect.south)); Wr.PutChar(wr, ' ');
Wr.PutText(wr, Fmt.Real(rect.east)); Wr.PutChar(wr, ' ');
Wr.PutText(wr, Fmt.Real(rect.north)); Wr.PutChar(wr, ' ')
END WriteRect;
======================== Callback Procedures ============================
Implementation Note:
In most cases, when examining Juno arguments passed on the Juno machine's
stack, we must use a NULL => TYPECASE arm to handle the possibility of
Modula-3 NIL being passed on the stack. However, we can omit this TYPECASE
arm when the expected value is a point, since the subsequent call to the
procedure JunoPt.FromValuePair on this argument will raise JunoPt.BadPt
in that case.
PROCEDURENewPathProc (dc: Closure): BOOLEAN = BEGIN ResetPath(dc.rt.currView.ps); RETURN TRUE END NewPathProc; PROCEDURENewPathProc2 (cl: ToFileClosure): BOOLEAN = BEGIN IF NewPathProc(cl) THEN TRY Wr.PutText(cl.i.wr, "newpath\n"); RETURN TRUE EXCEPT Wr.Failure => (* SKIP *) END END; RETURN TRUE END NewPathProc2; PROCEDUREMoveToProc (dc: Closure): BOOLEAN = VAR err := FALSE; pr := JunoArgs.ReadPair(1, err); BEGIN IF NOT err THEN WITH ps = dc.rt.currView.ps DO VAR pt: JunoPt.T; BEGIN TRY pt := JunoPt.FromValuePair(pr) EXCEPT JunoPt.BadPt => RETURN FALSE END; ps.moveto := TRUE; ps.movetoPt := pt; ps.currPt := pt; ps.subpathStartPt := pt; RETURN TRUE END END END; RETURN FALSE END MoveToProc; PROCEDUREMoveToProc2 (cl: ToFileClosure): BOOLEAN = BEGIN IF MoveToProc(cl) THEN TRY WITH wr = cl.i.wr DO WritePoint(wr, cl.rt.currView.ps.currPt); Wr.PutText(wr, "moveto\n") END; RETURN TRUE EXCEPT Wr.Failure => (* SKIP *) END ELSE (* SKIP *) END; RETURN FALSE END MoveToProc2; PROCEDUREStartSegment (VAR (*INOUT*) ps: State; ch: Drawing.ChildPublic): BOOLEAN =
Code executed when a new straight or curved segment is added to the path to maintain the invariants on themovetoandmovetoPtfields. Returns FALSE iff the current path is logically empty.
BEGIN
IF ps.moveto THEN
ps.moveto := FALSE;
Path.MoveTo(ps.path, JunoPt.ToHV(ps.movetoPt, ch.xform))
ELSIF Path.IsClosed(ps.path) THEN
RETURN FALSE
END;
RETURN TRUE
END StartSegment;
PROCEDURE LineToProc (dc: Closure): BOOLEAN =
BEGIN
WITH d = dc.rt.currView, ps = d.ps DO
VAR ch: Drawing.ChildPublic := Filter.Child(d); BEGIN
IF StartSegment(ps, ch) THEN
VAR err := FALSE; pr := JunoArgs.ReadPair(1, err); BEGIN
IF NOT err THEN
TRY ps.currPt := JunoPt.FromValuePair(pr) EXCEPT
JunoPt.BadPt => RETURN FALSE
END;
Path.LineTo(ps.path, JunoPt.ToHV(ps.currPt, ch.xform));
RETURN TRUE
END
END
END
END
END;
RETURN FALSE
END LineToProc;
PROCEDURE LineToProc2 (cl: ToFileClosure): BOOLEAN =
BEGIN
IF LineToProc(cl) THEN
TRY
WritePoint(cl.i.wr, cl.rt.currView.ps.currPt);
Wr.PutText(cl.i.wr, "lineto\n");
RETURN TRUE
EXCEPT Wr.Failure => (* SKIP *)
END
END;
RETURN FALSE
END LineToProc2;
PROCEDURE CurveToProc (dc: Closure): BOOLEAN =
VAR dummy1, dummy2, dummy3: JunoPt.T; BEGIN
RETURN CurveToWork(dc, dummy1, dummy2, dummy3)
END CurveToProc;
PROCEDURE CurveToProc2 (cl: ToFileClosure): BOOLEAN =
VAR pt1, pt2, pt3: JunoPt.T; BEGIN
IF CurveToWork(cl, pt1, pt2, pt3) THEN
WITH wr = cl.i.wr DO
TRY
WritePoint(wr, pt1);
WritePoint(wr, pt2);
WritePoint(wr, pt3);
Wr.PutText(wr, "curveto\n");
RETURN TRUE
EXCEPT
Wr.Failure => (* SKIP *)
END;
END
END;
RETURN FALSE
END CurveToProc2;
PROCEDURE CurveToWork (dc: Closure; VAR (*OUT*) pt1, pt2, pt3: JunoPt.T):
BOOLEAN =
BEGIN
WITH d = dc.rt.currView, ps = d.ps DO
VAR ch: Drawing.ChildPublic := Filter.Child(d); BEGIN
IF StartSegment(ps, ch) THEN
VAR
err := FALSE;
pr1 := JunoArgs.ReadPair(3, err);
pr2 := JunoArgs.ReadPair(2, err);
pr3 := JunoArgs.ReadPair(1, err);
BEGIN
IF NOT err THEN
TRY
pt1 := JunoPt.FromValuePair(pr1);
pt2 := JunoPt.FromValuePair(pr2);
pt3 := JunoPt.FromValuePair(pr3)
EXCEPT
JunoPt.BadPt => RETURN FALSE
END;
Path.CurveTo(ps.path,
JunoPt.ToHV(pt1, ch.xform),
JunoPt.ToHV(pt2, ch.xform),
JunoPt.ToHV(pt3, ch.xform));
ps.currPt := pt3;
RETURN TRUE
END
END
END
END
END;
RETURN FALSE
END CurveToWork;
PROCEDURE CloseProc (dc: Closure): BOOLEAN =
BEGIN
WITH d = dc.rt.currView, ps = d.ps DO
IF ps.moveto THEN
ps.moveto := FALSE;
VAR ch: Drawing.ChildPublic := Filter.Child(d); BEGIN
Path.MoveTo(ps.path, JunoPt.ToHV(ps.movetoPt, ch.xform))
END
ELSIF Path.IsClosed(ps.path) THEN
RETURN FALSE
END;
Path.Close(ps.path);
ps.currPt := ps.subpathStartPt
END;
RETURN TRUE
END CloseProc;
PROCEDURE CloseProc2 (cl: ToFileClosure): BOOLEAN =
BEGIN
IF CloseProc(cl) THEN
TRY
Wr.PutText(cl.i.wr, "closepath\n");
RETURN TRUE
EXCEPT Wr.Failure => (* SKIP *)
END;
END;
RETURN FALSE
END CloseProc2;
PROCEDURE StrokeProc (dc: Closure): BOOLEAN =
BEGIN
WITH d = dc.rt.currView, ps = d.ps DO
VAR ch: Drawing.ChildPublic := Filter.Child(d); BEGIN
VBT.Stroke(ch, Rect.Full, ps.path,
width := ROUND(ps.width * ch.xform.widthScale),
end := ps.end, join := ps.join, op := ps.colorOp)
END;
ResetPath(ps)
END;
RETURN TRUE
END StrokeProc;
PROCEDURE StrokeProc2 (cl: ToFileClosure): BOOLEAN =
BEGIN
TRY Wr.PutText(cl.i.wr, "stroke\n") EXCEPT
Wr.Failure => RETURN FALSE
END;
ResetPath(cl.rt.currView.ps);
RETURN TRUE
END StrokeProc2;
PROCEDURE FillProc (dc: Closure): BOOLEAN =
BEGIN
WITH d = dc.rt.currView, ps = d.ps DO
VAR ch: Drawing.ChildPublic := Filter.Child(d); BEGIN
VBT.Fill(ch, Rect.Full, ps.path, wind := ps.wind, op := ps.colorOp)
END;
ResetPath(ps)
END;
RETURN TRUE
END FillProc;
PROCEDURE FillProc2 (cl: ToFileClosure): BOOLEAN =
BEGIN
TRY
CASE cl.rt.currView.ps.wind OF
VBT.WindingCondition.NonZero => Wr.PutText(cl.i.wr, "fill\n")
| VBT.WindingCondition.Odd => Wr.PutText(cl.i.wr, "eofill\n")
END
EXCEPT
Wr.Failure => RETURN FALSE
END;
ResetPath(cl.rt.currView.ps);
RETURN TRUE
END FillProc2;
PROCEDURE TypeProc (dc: Closure): BOOLEAN =
VAR
err := FALSE;
pr := JunoArgs.ReadPair(2, err);
t := JunoArgs.ReadText(1, err);
BEGIN
IF NOT err THEN
WITH d = dc.rt.currView, ps = d.ps DO
VAR ch: Drawing.ChildPublic := Filter.Child(d); pt: JunoPt.T; BEGIN
TRY pt := JunoPt.FromValuePair(pr) EXCEPT
JunoPt.BadPt => RETURN FALSE
END;
VBT.PaintText(ch, fnt := ps.xFont, t := t,
pt := JunoPt.ToHV(pt, ch.xform),
op := ps.textColorOp);
RETURN TRUE
END
END
END;
RETURN FALSE
END TypeProc;
PROCEDURE TypeProc2 (cl: ToFileClosure): BOOLEAN =
VAR
err := FALSE;
pr := JunoArgs.ReadPair(2, err);
t := JunoArgs.ReadText(1, err);
BEGIN
IF NOT err THEN
VAR wr := cl.i.wr; pt: JunoPt.T; BEGIN
TRY
pt := JunoPt.FromValuePair(pr);
Wr.PutText(wr, "gsave\n");
WritePoint(wr, pt);
Wr.PutText(wr, "moveto\n(");
Wr.PutText(wr, EscapeString(t));
Wr.PutText(wr, ") show\n");
Wr.PutText(wr, "grestore\n")
EXCEPT
JunoPt.BadPt, Wr.Failure => RETURN FALSE
END;
RETURN TRUE
END
END;
RETURN FALSE
END TypeProc2;
PROCEDURE EscapeString (t: TEXT): TEXT =
Return a text equivalent to t, but with non-printing and PostScript-
special characters (namely, '(', ')', and '\') converted to octal escape
sequences.
CONST
PSSpecial = SET OF CHAR {'(', ')', '\\'};
Printing = SET OF CHAR {' ' .. '~'} - PSSpecial;
PROCEDURE OctalString(c: CHAR): TEXT =
BEGIN
IF c IN PSSpecial THEN RETURN Text.FromChar(c) END;
RETURN Fmt.Pad(Fmt.Int(ORD(c), base := 8), 3, padChar := '0')
END OctalString;
VAR res := ""; start := 0; c: CHAR; len := Text.Length(t); BEGIN
FOR i := 0 TO len - 1 DO
c := Text.GetChar(t, i);
IF NOT c IN Printing THEN
(* flush batch of chars in [start, i) *)
IF start < i THEN res := res & Text.Sub(t, start, i - start) END;
res := res & "\\" & OctalString(c);
start := i + 1
END
END;
(* fast path: no escaped characters *)
IF start = 0 THEN RETURN t END;
(* otherwise, flush suffix if necessary *)
IF start < len THEN res := res & Text.Sub(t, start, len - start) END;
RETURN res
END EscapeString;
PROCEDURE SetWidthProc (dc: Closure): BOOLEAN =
VAR err := FALSE; r := JunoArgs.ReadReal(1, err); BEGIN
IF NOT err AND r >= 0.0 THEN
dc.rt.currView.ps.width := r;
RETURN TRUE
END;
RETURN FALSE
END SetWidthProc;
PROCEDURE SetWidthProc2 (cl: ToFileClosure): BOOLEAN =
BEGIN
IF SetWidthProc(cl) THEN
TRY
Wr.PutText(cl.i.wr, Fmt.Real(cl.rt.currView.ps.width));
Wr.PutText(cl.i.wr, " setlinewidth\n");
RETURN TRUE
EXCEPT Wr.Failure => (* SKIP *)
END
END;
RETURN FALSE
END SetWidthProc2;
PROCEDURE GetWidthProc (dc: Closure): BOOLEAN =
BEGIN
JunoArgs.WriteReal(1, dc.rt.currView.ps.width);
RETURN TRUE
END GetWidthProc;
CONST EndMap = ARRAY [ButtEndsVal..SquareEndsVal] OF VBT.EndStyle{
VBT.EndStyle.Butt, VBT.EndStyle.Round, VBT.EndStyle.Square};
PROCEDURE SetEndStyleProc (dc: Closure): BOOLEAN =
VAR err := FALSE; es := JunoArgs.ReadInt(1, err); BEGIN
IF NOT err AND ButtEndsVal <= es AND es <= SquareEndsVal THEN
dc.rt.currView.ps.end := EndMap[es];
RETURN TRUE
END;
RETURN FALSE
END SetEndStyleProc;
CONST EndMapInv = ARRAY VBT.EndStyle OF INTEGER{
RoundEndsVal, ButtEndsVal, SquareEndsVal};
PROCEDURE SetEndStyleProc2 (cl: ToFileClosure): BOOLEAN =
BEGIN
IF SetEndStyleProc(cl) THEN
TRY
Wr.PutText(cl.i.wr, Fmt.Int(EndMapInv[cl.rt.currView.ps.end]));
Wr.PutText(cl.i.wr, " setlinecap\n")
EXCEPT Wr.Failure => (* SKIP *)
END
END;
RETURN TRUE
END SetEndStyleProc2;
PROCEDURE GetEndStyleProc (dc: Closure): BOOLEAN =
BEGIN
JunoArgs.WriteInt(1, EndMapInv[dc.rt.currView.ps.end]);
RETURN TRUE
END GetEndStyleProc;
CONST JoinMap = ARRAY [MiterJointsVal..BevelJointsVal] OF VBT.JoinStyle {
VBT.JoinStyle.Miter, VBT.JoinStyle.Round, VBT.JoinStyle.Bevel};
PROCEDURE SetJoinStyleProc (dc: Closure): BOOLEAN =
VAR err := FALSE; js := JunoArgs.ReadInt(1, err); BEGIN
IF NOT err AND MiterJointsVal <= js AND js <= BevelJointsVal THEN
dc.rt.currView.ps.join := JoinMap[js];
RETURN TRUE
END;
RETURN FALSE
END SetJoinStyleProc;
CONST JoinMapInv = ARRAY VBT.JoinStyle OF INTEGER {
RoundJointsVal, BevelJointsVal, MiterJointsVal};
PROCEDURE SetJoinStyleProc2 (cl: ToFileClosure): BOOLEAN =
BEGIN
IF SetJoinStyleProc(cl) THEN
TRY
Wr.PutText(cl.i.wr, Fmt.Int(JoinMapInv[cl.rt.currView.ps.join]));
Wr.PutText(cl.i.wr, " setlinejoin\n")
EXCEPT Wr.Failure => (* SKIP *)
END
END;
RETURN TRUE
END SetJoinStyleProc2;
PROCEDURE GetJoinStyleProc (dc: Closure): BOOLEAN =
BEGIN
JunoArgs.WriteInt(1, JoinMapInv[dc.rt.currView.ps.join]);
RETURN TRUE
END GetJoinStyleProc;
PROCEDURE ReadColor (VAR (*OUT*) color: Color): BOOLEAN =
If argument-1is a color value, setcolorto that value and return TRUE; otherwise, return FALSE.
VAR err := FALSE; p1 := JunoArgs.ReadPair(1, err); BEGIN
IF NOT err THEN
TYPECASE p1.cdr OF NULL => | RTVal.Pair (p2) =>
TYPECASE p2.cdr OF NULL => | RTVal.Pair (p3) =>
TYPECASE p1.car OF NULL => | RTVal.Number (r) =>
TYPECASE p2.car OF NULL => | RTVal.Number (g) =>
TYPECASE p3.car OF NULL => | RTVal.Number (b) =>
IF p3.cdr = RTVal.nil AND
0.0 <= r.val AND r.val <= 1.0 AND
0.0 <= g.val AND g.val <= 1.0 AND
0.0 <= b.val AND b.val <= 1.0 THEN
color := Color{r.val, g.val, b.val};
RETURN TRUE
END
ELSE (* SKIP *)
END
ELSE (* SKIP *)
END
ELSE (* SKIP *)
END
ELSE (* SKIP *)
END
ELSE (* SKIP *)
END
END;
RETURN FALSE
END ReadColor;
PROCEDURE SetColorProc (dc: Closure): BOOLEAN =
BEGIN
WITH ps = dc.rt.currView.ps, c = ps.color DO
IF ReadColor(c) THEN
ps.colorOp := PaintOp.FromRGB(c.r, c.g, c.b,
mode := PaintOp.Mode.Accurate, bw := PaintOp.BW.UseFg);
ps.textColorOp := PaintOp.Pair(PaintOp.Transparent, ps.colorOp);
RETURN TRUE
END
END;
RETURN FALSE
END SetColorProc;
PROCEDURE SetColorProc2 (cl: ToFileClosure): BOOLEAN =
BEGIN
WITH c = cl.rt.currView.ps.color DO
TRY
IF ReadColor(c) THEN
WITH wr = cl.i.wr DO
Wr.PutText(wr, Fmt.Real(c.r)); Wr.PutChar(wr, ' ');
Wr.PutText(wr, Fmt.Real(c.g)); Wr.PutChar(wr, ' ');
Wr.PutText(wr, Fmt.Real(c.b));
Wr.PutText(wr, " setrgbcolor\n")
END;
RETURN TRUE
END
EXCEPT Wr.Failure => (* SKIP *)
END
END;
RETURN FALSE
END SetColorProc2;
PROCEDURE GetColorProc (dc: Closure): BOOLEAN =
BEGIN
WITH color = dc.rt.currView.ps.color DO
JunoArgs.WriteValue(1,
RTVal.FromPair(RTVal.FromReal(color.r),
RTVal.FromPair(RTVal.FromReal(color.g),
RTVal.FromPair(RTVal.FromReal(color.b),
RTVal.nil))))
END;
RETURN TRUE
END GetColorProc;
CONST WindMap = ARRAY [NZWindingVal..OddWindingVal] OF VBT.WindingCondition {
VBT.WindingCondition.NonZero, VBT.WindingCondition.Odd};
PROCEDURE SetWindingProc (dc: Closure): BOOLEAN =
VAR err := FALSE; ws := JunoArgs.ReadInt(1, err); BEGIN
IF NOT err AND NZWindingVal <= ws AND ws <= OddWindingVal THEN
dc.rt.currView.ps.wind := WindMap[ws];
RETURN TRUE
END;
RETURN FALSE
END SetWindingProc;
CONST WindMapInv = ARRAY VBT.WindingCondition OF INTEGER {
OddWindingVal, NZWindingVal};
PROCEDURE GetWindingProc (dc: Closure): BOOLEAN =
BEGIN
JunoArgs.WriteInt(1, WindMapInv[dc.rt.currView.ps.wind]);
RETURN TRUE
END GetWindingProc;
PROCEDURE GetXInfo (face: TEXT; size: INTEGER): PSFont.XInfo =
VAR ref: REFANY; BEGIN
IF NOT fontTbl.get(face & Fmt.Int(size), ref) THEN ref := NIL END;
RETURN NARROW(ref, PSFont.XInfo)
END GetXInfo;
PROCEDURE SetFaceProc (dc: Closure): BOOLEAN =
VAR err := FALSE; nm := JunoArgs.ReadText(1, err); BEGIN
IF NOT err THEN
WITH ps = dc.rt.currView.ps DO
VAR xInfo := GetXInfo(nm, ps.size); BEGIN
IF xInfo = NIL THEN RETURN FALSE END;
ps.face := nm; ps.ptSize := xInfo.ptSize;
ps.xFont := Font.FromName(ARRAY OF TEXT{xInfo.name});
RETURN TRUE
END
END
END;
RETURN FALSE
END SetFaceProc;
PROCEDURE SetFaceProc2 (cl: ToFileClosure): BOOLEAN =
VAR err := FALSE; nm := JunoArgs.ReadText(1, err); BEGIN
IF NOT err THEN
WITH ps = cl.rt.currView.ps, wr = cl.i.wr DO
VAR ref: REFANY; xInfo := GetXInfo(nm, ps.size); BEGIN
IF xInfo = NIL OR NOT metricTbl.get(nm, ref) THEN
RETURN FALSE
END;
ps.face := nm; ps.ptSize := xInfo.ptSize;
ps.psMetric := ref;
TRY
Wr.PutChar(wr, '/'); Wr.PutText(wr, nm);
WriteFindFont(wr);
Wr.PutText(wr, Fmt.Real(xInfo.ptSize));
Wr.PutText(wr, " scalefont setfont\n")
EXCEPT
Wr.Failure => RETURN FALSE
END;
RETURN TRUE
END
END
END;
RETURN FALSE
END SetFaceProc2;
PROCEDURE SetSizeProc (dc: Closure): BOOLEAN =
VAR err := FALSE; sz := JunoArgs.ReadInt(1, err); BEGIN
IF NOT err AND sz >= 0 THEN
WITH ps = dc.rt.currView.ps DO
VAR xInfo := GetXInfo(ps.face, sz); BEGIN
IF xInfo = NIL THEN RETURN FALSE END;
ps.size := sz; ps.ptSize := xInfo.ptSize;
ps.xFont := Font.FromName(ARRAY OF TEXT{xInfo.name});
RETURN TRUE
END
END
END;
RETURN FALSE
END SetSizeProc;
PROCEDURE SetSizeProc2 (cl: ToFileClosure): BOOLEAN =
VAR err := FALSE; sz := JunoArgs.ReadInt(1, err); BEGIN
IF NOT err AND sz >= 0 THEN
WITH ps = cl.rt.currView.ps, wr = cl.i.wr DO
VAR xInfo := GetXInfo(ps.face, sz); BEGIN
IF xInfo = NIL THEN RETURN FALSE END;
ps.size := sz; ps.ptSize := xInfo.ptSize;
TRY
Wr.PutChar(wr, '/'); Wr.PutText(wr, ps.face);
WriteFindFont(wr);
Wr.PutText(wr, Fmt.Real(xInfo.ptSize));
Wr.PutText(wr, " scalefont setfont\n")
EXCEPT
Wr.Failure => RETURN FALSE
END;
RETURN TRUE
END
END
END;
RETURN FALSE
END SetSizeProc2;
PROCEDURE SetFontProc (dc: Closure): BOOLEAN =
VAR
err := FALSE;
nm := JunoArgs.ReadText(2, err);
sz := JunoArgs.ReadInt(1, err);
BEGIN
IF NOT err AND sz >= 0 THEN
VAR xInfo := GetXInfo(nm, sz); BEGIN
IF xInfo = NIL THEN RETURN FALSE END;
WITH ps = dc.rt.currView.ps DO
ps.face := nm; ps.size := sz; ps.ptSize := xInfo.ptSize;
ps.xFont := Font.FromName(ARRAY OF TEXT{xInfo.name})
END;
RETURN TRUE
END
END;
RETURN FALSE
END SetFontProc;
PROCEDURE SetFontProc2 (cl: ToFileClosure): BOOLEAN =
VAR
err := FALSE;
nm := JunoArgs.ReadText(2, err);
sz := JunoArgs.ReadInt(1, err);
BEGIN
IF NOT err AND sz >= 0 THEN
VAR xInfo := GetXInfo(nm, sz); BEGIN
IF xInfo = NIL THEN RETURN FALSE END;
WITH ps = cl.rt.currView.ps, wr = cl.i.wr DO
VAR ref: REFANY; BEGIN
IF NOT metricTbl.get(nm, ref) THEN RETURN FALSE END;
ps.psMetric := ref
END;
ps.face := nm; ps.size := sz; ps.ptSize := xInfo.ptSize;
TRY
Wr.PutChar(wr, '/'); Wr.PutText(wr, nm);
WriteFindFont(wr);
Wr.PutText(wr, Fmt.Real(xInfo.ptSize));
Wr.PutText(wr, " scalefont setfont\n")
EXCEPT
Wr.Failure => RETURN FALSE
END;
RETURN TRUE
END
END
END;
RETURN FALSE
END SetFontProc2;
PROCEDURE GetFaceProc (dc: Closure): BOOLEAN =
BEGIN
JunoArgs.WriteText(1, dc.rt.currView.ps.face);
RETURN TRUE
END GetFaceProc;
PROCEDURE GetSizeProc (dc: Closure): BOOLEAN =
BEGIN
JunoArgs.WriteInt(1, dc.rt.currView.ps.size);
RETURN TRUE
END GetSizeProc;
PROCEDURE GetFontProc (dc: Closure): BOOLEAN =
BEGIN
JunoArgs.WriteText(2, dc.rt.currView.ps.face);
JunoArgs.WriteInt(1, dc.rt.currView.ps.size);
RETURN TRUE
END GetFontProc;
PROCEDURE GetPtSizeProc (dc: Closure): BOOLEAN =
BEGIN
JunoArgs.WriteReal(1, dc.rt.currView.ps.ptSize);
RETURN TRUE
END GetPtSizeProc;
PROCEDURE FontHProc (dc: Closure): BOOLEAN =
Note: We can use adummystring, since we only care about the ascent and descent of the font, andVBT.BoundingBoxreturns the same ascent and descent regardless of its argument.
BEGIN
WITH d = dc.rt.currView DO
VAR
ch: Drawing.ChildPublic := Filter.Child(d);
bbox := VBT.BoundingBox(ch, "a", d.ps.xFont);
BEGIN
WITH yScale = ch.xform.yScale DO
JunoArgs.WriteReal(2, -FLOAT(bbox.north, JunoValue.Real) / yScale);
JunoArgs.WriteReal(1, FLOAT(bbox.south, JunoValue.Real) / yScale)
END;
RETURN TRUE
END
END
END FontHProc;
PROCEDURE FontHProc2 (cl: ToFileClosure): BOOLEAN =
BEGIN
WITH
ps = cl.rt.currView.ps,
sz = ps.ptSize,
bbox = ps.psMetric.bbox
DO
JunoArgs.WriteReal(2, sz * bbox.north);
JunoArgs.WriteReal(1, -sz * bbox.south)
END;
RETURN TRUE
END FontHProc2;
PROCEDURE StringWProc (dc: Closure): BOOLEAN =
VAR err := FALSE; t := JunoArgs.ReadText(1, err); BEGIN
IF NOT err THEN
WITH d = dc.rt.currView DO
VAR
ch: Drawing.ChildPublic := Filter.Child(d);
w := VBT.TextWidth(ch, t, d.ps.xFont);
BEGIN
JunoArgs.WriteReal(2, FLOAT(w, JunoValue.Real) / ch.xform.xScale)
END;
RETURN TRUE
END
END;
RETURN FALSE
END StringWProc;
PROCEDURE StringWProc2 (cl: ToFileClosure): BOOLEAN =
VAR err := FALSE; t := JunoArgs.ReadText(1, err); BEGIN
IF NOT err THEN
WITH metric = cl.rt.currView.ps.psMetric DO
VAR total: JunoValue.Real := 0.0; BEGIN
FOR i := 0 TO Text.Length(t) - 1 DO
VAR code := ORD(Text.GetChar(t, i)); BEGIN
IF metric.mapped[code] THEN
total := total + metric.width[code]
END
END
END;
JunoArgs.WriteReal(2, total * cl.rt.currView.ps.ptSize);
RETURN TRUE
END
END
END;
RETURN FALSE
END StringWProc2;
PROCEDURE StringBBProc (dc: Closure): BOOLEAN =
VAR err := FALSE; t := JunoArgs.ReadText(1, err); BEGIN
IF NOT err THEN
WITH d = dc.rt.currView DO
VAR
ch: Drawing.ChildPublic := Filter.Child(d);
r: Rect.T := VBTExtras.TightBoundingBox(ch, t, d.ps.xFont);
res: JunoRect.T;
BEGIN
IF r = Rect.Empty THEN
res := JunoRect.Empty
ELSE
WITH xScale = ch.xform.xScale, yScale = ch.xform.yScale DO
res := JunoRect.T{
(FLOAT( r.west, JunoValue.Real) - 0.49) / xScale,
(FLOAT( r.east, JunoValue.Real) - 0.49) / xScale,
(FLOAT(-r.north, JunoValue.Real) + 0.51) / yScale,
(FLOAT(-r.south, JunoValue.Real) + 0.51) / yScale}
END
END;
JunoArgs.WriteValue(2, JunoRect.ToRTVal(res));
RETURN TRUE
END
END
END;
RETURN FALSE
END StringBBProc;
PROCEDURE StringBBProc2 (cl: ToFileClosure): BOOLEAN =
VAR err := FALSE; t := JunoArgs.ReadText(1, err); BEGIN
IF NOT err THEN
WITH ps = cl.rt.currView.ps DO
VAR res: JunoRect.T; empty := TRUE; refPt := 0.0; BEGIN
FOR i := 0 TO Text.Length(t) - 1 DO
VAR code := ORD(Text.GetChar(t, i)); BEGIN
IF NOT ps.psMetric.mapped[code] THEN
(* Map unencoded characters to the space character *)
code := ORD(' ');
<* ASSERT ps.psMetric.mapped[code] *>
END;
VAR
bbox := ps.psMetric.charBB[code];
bbox2: JunoRect.T;
BEGIN
IF bbox # NIL THEN
bbox2 := JunoRect.Add(bbox^, JunoPt.T{refPt, 0.0});
IF empty
THEN empty := FALSE; res := bbox2
ELSE res := JunoRect.Join(res, bbox2)
END
END;
refPt := refPt + ps.psMetric.width[code]
END
END
END;
IF empty
THEN res := JunoRect.T{0.0, 0.0, 0.0, 0.0}
ELSE res := JunoRect.Scale(res, ps.ptSize)
END;
JunoArgs.WriteValue(2, JunoRect.ToRTVal(res));
RETURN TRUE
END
END
END;
RETURN FALSE
END StringBBProc2;
PROCEDURE CurrPtProc (dc: Closure): BOOLEAN =
BEGIN
WITH ps = dc.rt.currView.ps DO
IF NOT ps.moveto AND Path.IsClosed(ps.path)
THEN JunoArgs.WriteValue(1, RTVal.nil)
ELSE JunoArgs.WriteValue(1, JunoPt.ToValuePair(ps.currPt))
END
END;
RETURN TRUE
END CurrPtProc;
VAR Nil := RTVal.nil;
TYPE
JunoMO = Path.MapObject BRANDED "PSImpl.JunoMO" OBJECT
ch: Drawing.ChildPublic;
head, curr: RTVal.Pair;
METHODS
init(): JunoMO := JunoMOInit
OVERRIDES
move := AddMoveTo;
line := AddLineTo;
curve := AddCurveTo;
close := AddClose
END;
PROCEDURE JunoMOInit (self: JunoMO): JunoMO =
BEGIN
self.head := RTVal.FromPair(Nil, Nil);
self.curr := self.head;
RETURN self
END JunoMOInit;
PROCEDURE AddNewList (self: JunoMO; nm: TEXT): RTVal.Pair =
VAR pr := RTVal.FromPair(RTVal.FromText(nm), Nil); BEGIN
self.curr.cdr := RTVal.FromPair(pr, Nil);
self.curr := self.curr.cdr;
RETURN pr
END AddNewList;
PROCEDURE AddPt (
VAR (*INOUT*) pr: RTVal.Pair;
READONLY pt: Point.T;
ch: Drawing.ChildPublic) =
VAR pair := JunoPt.ToValuePair(JunoPt.FromHV(pt, ch.xform)); BEGIN
pr.cdr := RTVal.FromPair(pair, Nil);
pr := pr.cdr;
END AddPt;
PROCEDURE AddMoveTo (self: JunoMO; READONLY pt: Point.T) =
VAR pr := AddNewList(self, "MoveTo"); BEGIN
AddPt(pr, pt, self.ch);
pr.cdr := Nil
END AddMoveTo;
PROCEDURE AddLineTo (
self: JunoMO;
<*UNUSED*> READONLY pt1: Point.T;
READONLY pt2: Point.T) =
VAR pr := AddNewList(self, "LineTo"); BEGIN
AddPt(pr, pt2, self.ch);
pr.cdr := Nil
END AddLineTo;
PROCEDURE AddCurveTo (
self: JunoMO;
<*UNUSED*> READONLY pt1: Point.T;
READONLY pt2, pt3, pt4: Point.T)=
VAR pr := AddNewList(self, "CurveTo"); BEGIN
AddPt(pr, pt2, self.ch);
AddPt(pr, pt3, self.ch);
AddPt(pr, pt4, self.ch);
pr.cdr := Nil
END AddCurveTo;
PROCEDURE AddClose (self: JunoMO; <*UNUSED*> READONLY pt1, pt2: Point.T) =
VAR pr := AddNewList(self, "Close"); BEGIN
pr.cdr := Nil
END AddClose;
PROCEDURE CurrPathProc (dc: Closure): BOOLEAN =
<* FATAL Path.Malformed *>
VAR jmo: JunoMO; BEGIN
WITH d = dc.rt.currView, ps = d.ps DO
jmo := NEW(JunoMO, ch := Filter.Child(d)).init();
Path.Map(ps.path, jmo);
IF ps.moveto THEN
jmo.move(JunoPt.ToHV(ps.movetoPt, jmo.ch.xform))
END;
JunoArgs.WriteValue(1, jmo.head.cdr)
END;
RETURN TRUE
END CurrPathProc;
PROCEDURE SetBBoxProc (dc: Closure): BOOLEAN =
VAR
err := FALSE;
pr1 := JunoArgs.ReadPair(2, err);
pr2 := JunoArgs.ReadPair(1, err);
pt1, pt2: JunoPt.T;
BEGIN
IF NOT err THEN
TRY
pt1 := JunoPt.FromValuePair(pr1);
pt2 := JunoPt.FromValuePair(pr2)
EXCEPT
JunoPt.BadPt => RETURN FALSE
END;
WITH bbox = dc.rt.currView.ps.bbox DO
bbox.west := MIN(pt1.x, pt2.x);
bbox.east := MAX(pt1.x, pt2.x);
bbox.south := MIN(pt1.y, pt2.y);
bbox.north := MAX(pt1.y, pt2.y)
END;
RETURN TRUE
END;
RETURN FALSE
END SetBBoxProc;
PROCEDURE GetBBoxProc (dc: Closure): BOOLEAN =
BEGIN
WITH bbox = dc.rt.currView.ps.bbox DO
JunoArgs.WriteValue(2, JunoPt.ToValuePair(
JunoPt.T{x := bbox.west, y := bbox.south}));
JunoArgs.WriteValue(1, JunoPt.ToValuePair(
JunoPt.T{x := bbox.east, y := bbox.north}))
END;
RETURN TRUE
END GetBBoxProc;
PROCEDURE ShowPageProc (dc: Closure): BOOLEAN =
BEGIN
Drawing.Sync(Filter.Child(dc.rt.currView));
RETURN TRUE
END ShowPageProc;
PROCEDURE ShowPageProc2 (cl: ToFileClosure): BOOLEAN =
BEGIN
INC(cl.i.page);
TRY
WITH wr = cl.i.wr DO
WritePageTrailer(wr);
Wr.PutText(wr, "showpage\n");
WritePageHeader(wr, cl.i.page)
END;
RETURN TRUE
EXCEPT Wr.Failure => (* SKIP *)
END;
RETURN FALSE
END ShowPageProc2;
PROCEDURE ResetProc (dc: Closure): BOOLEAN =
VAR d := dc.rt.currView; ch: Drawing.ChildPublic := Filter.Child(d); BEGIN
VBT.PaintTint(ch, Rect.Full, PaintOp.Bg);
Reset(d);
RETURN TRUE
END ResetProc;
PROCEDURE SavePageProc (dc: Closure): BOOLEAN =
BEGIN
DblBufferVBT.Save(Filter.Child(dc.rt.currView));
RETURN TRUE
END SavePageProc;
PROCEDURE SavePageProc2 (<*UNUSED*> cl: ToFileClosure): BOOLEAN =
BEGIN RETURN TRUE END SavePageProc2;
PROCEDURE RestorePageProc (dc: Closure): BOOLEAN =
BEGIN
DblBufferVBT.Restore(Filter.Child(dc.rt.currView));
RETURN TRUE
END RestorePageProc;
PROCEDURE RestorePageProc2 (<*UNUSED*> cl: ToFileClosure): BOOLEAN =
BEGIN RETURN TRUE END RestorePageProc2;
BEGIN
(* read the font data from the pickle *)
<* FATAL Rd.Failure, Rd.EndOfFile, Rsrc.NotFound *>
VAR
rd := Rsrc.Open("FontData.pkl", JunoRsrc.Path);
fontData: PSFont.Data;
BEGIN
TRY fontData := Pickle.Read(rd) EXCEPT Pickle.Error (msg) =>
<* FATAL Wr.Failure *> BEGIN
Wr.PutText(stderr, "Error reading pickled font data: " & msg & "\n");
Wr.Flush(stderr)
END;
Process.Exit(1)
END;
Rd.Close(rd);
fontTbl := fontData.fontTbl;
metricTbl := fontData.metricTbl
END;
(* set defaultXFont *)
VAR xInfo := GetXInfo(DefaultFaceName, DefaultFontSize); BEGIN
IF xInfo = NIL THEN RAISE Error END;
defaultXFont := Font.FromName(ARRAY OF TEXT{xInfo.name});
defaultXFontPtSize := xInfo.ptSize
END;
(* set default metric *)
VAR ref: REFANY; BEGIN
IF metricTbl.get(DefaultFaceName, ref)
THEN defaultPSMetric := ref
ELSE RAISE Error
END
END
END PSImpl.