Copyright (C) 1994, Digital Equipment Corp.
MODULE GEF EXPORTS GEF, GEFInternal;
IMPORT Axis, Filename, FileRd, Fmt, GEFClass, GEFError, GraphVBT,
GraphVBTExtras, RefList, Math, OSError, PaintOp, Point, R2, Rd,
IntRefTbl, Rsrc, SLispClass, Sx, Text, TextRd, Thread, VBT;
<* PRAGMA LL *>
<* FATAL Fatal, Sx.PrintError, Thread.Alerted *>
EXCEPTION Fatal;
VAR
mu := NEW(Thread.Mutex);
******************** Initialization ******************************
PROCEDURE InitFromFile (t : T;
filename : TEXT;
intervals : IntRefTbl.T;
showAllElements: BOOLEAN )
RAISES {GEFError.T, Rd.Failure, Thread.Alerted} =
VAR rd: Rd.T;
BEGIN
TRY
rd := FileRd.Open(Filename.ExpandTilde(filename));
TRY
InitFromRd(t, rd, intervals, showAllElements)
FINALLY
Rd.Close(rd)
END
EXCEPT
| OSError.E, Filename.Error =>
RAISE GEFError.T("Could not open filename: " & filename)
END
END InitFromFile;
PROCEDURE InitFromText (t : T;
description : TEXT;
intervals : IntRefTbl.T;
showAllElements: BOOLEAN )
RAISES {GEFError.T, Thread.Alerted} = <* FATAL Rd.Failure *>
BEGIN
InitFromRd(t, TextRd.New(description), intervals, showAllElements)
END InitFromText;
PROCEDURE InitFromRsrc (t : T;
name : TEXT;
path : Rsrc.Path;
intervals : IntRefTbl.T;
showAllElements: BOOLEAN )
RAISES {GEFError.T, Rd.Failure, Rsrc.NotFound, Thread.Alerted} =
VAR rd: Rd.T;
BEGIN
rd := Rsrc.Open(name, path);
TRY InitFromRd(t, rd, intervals, showAllElements) FINALLY Rd.Close(rd) END
END InitFromRsrc;
TYPE
ReaderClosure = Thread.SizedClosure OBJECT
t : T;
rd : Rd.T;
errType: ErrType;
errArg : REFANY;
intervals : IntRefTbl.T;
OVERRIDES
apply := Read
END;
ErrType = {ReadError, EndOfFile, Failure, Alerted};
PROCEDURE Read (rc: ReaderClosure): S_exp =
VAR
exp : S_exp;
gotIt := FALSE;
BEGIN
TRY
exp := SLispClass.ReadToTable(rc.rd, rc.intervals);
gotIt := TRUE;
IF Rd.EOF(rc.rd) THEN RETURN exp END; (* Check for extra garbage: *)
EVAL Sx.Read(rc.rd);
RAISE Sx.ReadError("extra characters on input")
EXCEPT
| Sx.ReadError (txt) =>
rc.errArg := txt;
rc.errType := ErrType.ReadError
| Rd.EndOfFile =>
IF gotIt THEN RETURN exp END;
rc.errType := ErrType.EndOfFile
| Rd.Failure (ref) => rc.errArg := ref; rc.errType := ErrType.Failure
| Thread.Alerted => rc.errType := ErrType.Alerted
END; (* If there's an error, we return the ReaderClosure itself. *)
RETURN rc
END Read;
PROCEDURE InitFromRd (t : T;
rd : Rd.T;
intervals : IntRefTbl.T;
showAllElements: BOOLEAN )
RAISES {GEFError.T, Rd.Failure, Thread.Alerted} =
VAR
reader := Thread.Fork(NEW(ReaderClosure, t := t, rd := rd,
intervals := intervals, stackSize := 10000));
(* to get a big stack *)
BEGIN
TRY
TYPECASE Thread.AlertJoin(reader) OF
| ReaderClosure (rc) =>
CASE rc.errType OF
| ErrType.ReadError =>
RAISE GEFError.T(Text.Cat("Sx.ReadError: ", rc.errArg))
| ErrType.EndOfFile => RAISE GEFError.T("End of input")
| ErrType.Failure => RAISE Rd.Failure(rc.errArg)
| ErrType.Alerted => RAISE Thread.Alerted
END
| S_exp (desc) => InitFromSx(t, desc, showAllElements)
END
EXCEPT
| Thread.Alerted => Thread.Alert(reader);
END;
END InitFromRd;
PROCEDURE InitFromSx (t : T;
sx : S_exp;
showAllElements: BOOLEAN )
RAISES {GEFError.T, Thread.Alerted} =
BEGIN
LOCK mu DO GEFClass.Parse(t, sx, showAllElements); END;
END InitFromSx;
******************************* Misc *******************************
PROCEDURE MoveElem (t: T; elem: REFANY; pt: Point.T) =
<* FATAL GEFError.T *>
BEGIN
TYPECASE elem OF
| Vertex (vertex) =>
VAR
reals: Reals := GEFClass.GetElemField(t, elem, "Pos");
pos := GraphVBTExtras.ScreenPtToWorldPos(t, pt);
BEGIN
reals[0] := pos[0];
reals[1] := pos[1];
GEFClass.SetElemField(t, elem, "Pos", reals);
vertex.posCovered := TRUE;
LOCK t.mu DO vertex.move(pos); END;
vertex.posCovered := FALSE;
END;
ELSE
END;
END MoveElem;
PROCEDURE AddElem (t: T; elem: REFANY) =
VAR
elems: Elems := GEFClass.GetElemField(t, t, "Contents");
<* FATAL GEFError.T *>
BEGIN
WITH new = NEW(Elems, NUMBER(elems^) + 1) DO
SUBARRAY(new^, 0, NUMBER(elems^)) := elems^;
new[LAST(new^)] := elem;
GEFClass.SetElemField(t, t, "Contents", new);
END;
END AddElem;
PROCEDURE RedisplayImage (t: T) =
BEGIN
t.redisplay();
END RedisplayImage;
********************************* Graph **********************
TYPE
ParseObject = GEFClass.ParseObject;
Elem = GEFClass.Elem;
Elems = GEFClass.Elems;
Ints = GEFClass.Ints;
Bools = GEFClass.Bools;
Reals = GEFClass.Reals;
Texts = GEFClass.Texts;
TYPE
GraphParseObject = ParseObject OBJECT
OVERRIDES
create := GraphCreate;
delete := GraphDelete;
getId := GraphGetId;
setReal := GraphSetReal;
setInt := GraphSetInt;
setElem := GraphSetElem;
finish := GraphFinish;
isType := GraphIsType;
END;
PROCEDURE GraphCreate (<* UNUSED *> gpo: ParseObject; t: T; id: INTEGER):
S_exp =
BEGIN
t.id := id;
RETURN t;
END GraphCreate;
PROCEDURE GraphDelete (<* UNUSED *> po : ParseObject;
<* UNUSED *> t : T;
<* UNUSED *> elem: Elem ) =
BEGIN
END GraphDelete;
PROCEDURE GraphGetId (<* UNUSED *> gpo : ParseObject;
t : T;
<* UNUSED *> elem: Elem ): INTEGER =
BEGIN
RETURN t.id
END GraphGetId;
TYPE
GraphFieldType =
{World, Margin, PixelSizeDivisor, Aspect, PrefSize, ClientData, Contents};
PROCEDURE GraphSetReal (<* UNUSED *> gpo : ParseObject;
<* UNUSED *> t : T;
elem : Elem;
field: INTEGER;
value: Reals )
RAISES {GEFError.T} =
VAR graph := NARROW(elem, T);
BEGIN
LOCK graph.mu DO
CASE VAL(field, GraphFieldType) OF
| GraphFieldType.World =>
graph.setWorld(GraphVBT.WorldRectangle{
value[0], value[1], value[2], value[3]});
| GraphFieldType.Margin => graph.setMargin(value[0]);
| GraphFieldType.Aspect => graph.setAspect(value[0]);
| GraphFieldType.PrefSize =>
graph.setPreferredSize(ARRAY Axis.T OF REAL{value[0], value[1]});
ELSE
RAISE Fatal;
END;
END
END GraphSetReal;
PROCEDURE GraphSetInt (<* UNUSED *> gpo : ParseObject;
<* UNUSED *> t : T;
elem : Elem;
field: INTEGER;
value: Ints )
RAISES {GEFError.T} =
VAR graph := NARROW(elem, T);
BEGIN
LOCK graph.mu DO
CASE VAL(field, GraphFieldType) OF
| GraphFieldType.PixelSizeDivisor =>
WITH psd1 = value[0],
psd2 = value[1] DO
IF psd1 < 0 OR psd2 < 0 THEN
RAISE
GEFError.T(
Fmt.F("Bad PixelSizeDivisors (must be positive): %s %s",
Fmt.Int(psd1), Fmt.Int(psd2)))
END;
graph.setPixelSizeDivisor(
ARRAY [0 .. 1] OF CARDINAL{psd1, psd2});
END;
ELSE
RAISE Fatal;
END;
END;
END GraphSetInt;
PROCEDURE GraphSetElem (<* UNUSED *> gpo : ParseObject;
t : T;
elem : Elem;
field: INTEGER;
value: Elems ) RAISES {GEFError.T} =
VAR graph := NARROW(elem, T);
BEGIN
LOCK t.mu DO
CASE VAL(field, GraphFieldType) OF
| GraphFieldType.ClientData =>
graph.clientData := value[0];
| GraphFieldType.Contents =>
IF graph.elems = NIL OR (NUMBER(graph.elems^) # NUMBER(value^)) THEN
graph.elems := NEW(Elems, NUMBER(value^));
END;
graph.elems^ := value^;
ELSE
RAISE Fatal;
END;
END;
END GraphSetElem;
PROCEDURE GraphFinish (<* UNUSED *> gpo : ParseObject;
t : T;
<* UNUSED *> graphRA: REFANY )
RAISES {GEFError.T} =
BEGIN
VBT.Mark(t);
END GraphFinish;
PROCEDURE GraphIsType(<* UNUSED *> po: ParseObject; obj: REFANY): BOOLEAN =
BEGIN
RETURN ISTYPE(obj, T);
END GraphIsType;
************************************** Vertex ****************************
REVEAL
Vertex = VPublic BRANDED OBJECT
initialized := FALSE;
posCovered := FALSE;
id: INTEGER;
zOrder: ZOrder;
OVERRIDES
move := VertexSetPos;
setSize := VertexSetSize;
setShape := VertexSetShape;
setLabel := VertexSetLabel;
setColor := VertexSetColor;
setFont := VertexSetFont;
setFontColor := VertexSetFontColor;
setBorder := VertexSetBorder;
setBorderColor := VertexSetBorderColor;
toFront := VertexToFront;
toBack := VertexToBack;
END;
<* INLINE *>
PROCEDURE NewPos (pos: R2.T): GEFClass.Reals =
VAR res := NEW(GEFClass.Reals, 2);
BEGIN
res^ := pos;
RETURN res;
END NewPos;
PROCEDURE VertexSetPos (t : Vertex;
pos : R2.T;
animated: BOOLEAN;
start := 0.0; stop := 0.0;
path : GraphVBT.AnimationPath) =
<* FATAL GEFError.T *>
BEGIN
IF t.initialized THEN
GraphVBT.Vertex.move(t, pos, animated, start, stop, path);
(* motion can come from rotates, moves, etc. and the position
GEF stores for the vertex should be updated whenever it changes.
It is easier (and somewhat less efficient) to update the
value from here. SCG 19 Feb. 1993 *)
IF NOT t.posCovered THEN
GEFClass.UpdateElemField(t.graph, t, "Pos", NewPos(pos));
END;
ELSE
t.pos := pos;
END;
END VertexSetPos;
PROCEDURE VertexSetSize (t: Vertex; size: R2.T) =
BEGIN
IF t.initialized THEN
GraphVBT.Vertex.setSize(t, size);
ELSE
t.size := size;
END;
END VertexSetSize;
PROCEDURE VertexSetShape (t: Vertex; shape: GraphVBT.VertexShape) =
BEGIN
IF t.initialized THEN
GraphVBT.Vertex.setShape(t, shape);
ELSE
t.shape := shape;
END;
END VertexSetShape;
PROCEDURE VertexSetColor (t: Vertex; color: PaintOp.T) =
BEGIN
IF t.initialized THEN
GraphVBT.Vertex.setColor(t, color);
ELSE
t.color := color;
END;
END VertexSetColor;
PROCEDURE VertexSetLabel (t: Vertex; v: TEXT) =
BEGIN
IF t.initialized THEN
GraphVBT.Vertex.setLabel(t, v);
ELSE
t.label := v;
END;
END VertexSetLabel;
PROCEDURE VertexSetFont (t: Vertex; v: GraphVBT.WorldFont) =
BEGIN
IF t.initialized THEN
GraphVBT.Vertex.setFont(t, v);
ELSE
t.font := v;
END;
END VertexSetFont;
PROCEDURE VertexSetFontColor (t: Vertex; v: PaintOp.T) =
BEGIN
IF t.initialized THEN
GraphVBT.Vertex.setFontColor(t, v);
ELSE
t.fontColor := v;
END;
END VertexSetFontColor;
PROCEDURE VertexSetBorder (t: Vertex; v: REAL) =
BEGIN
IF t.initialized THEN
GraphVBT.Vertex.setBorder(t, v);
ELSE
t.border := v;
END;
END VertexSetBorder;
PROCEDURE VertexSetBorderColor (t: Vertex; v: PaintOp.T) =
BEGIN
IF t.initialized THEN
GraphVBT.Vertex.setBorderColor(t, v);
ELSE
t.fontColor := v;
END;
END VertexSetBorderColor;
PROCEDURE VertexToFront(t: Vertex; zOrder: GraphVBT.ZOrder) =
BEGIN
IF t.initialized THEN
GraphVBT.Vertex.toFront(t, zOrder);
ELSE
t.zOrder := front[zOrder]
END;
END VertexToFront;
PROCEDURE VertexToBack(t: Vertex; zOrder: GraphVBT.ZOrder) =
BEGIN
IF t.initialized THEN
GraphVBT.Vertex.toBack(t, zOrder);
ELSE
t.zOrder := back[zOrder]
END;
END VertexToBack;
TYPE
VertexParseObject = ParseObject OBJECT
zOrder: ZOrder;
OVERRIDES
create := VertexCreate;
delete := VertexDelete;
getId := VertexGetId;
setReal := VertexSetReal;
setText := VertexSetText;
setInt := VertexSetEnum;
finish := VertexFinish;
isType := VertexIsType;
END;
PROCEDURE VertexCreate (<* UNUSED *> gpo: VertexParseObject;
t : T;
id : INTEGER ): REFANY =
BEGIN
RETURN NEW(Vertex, graph := t, id := id)
END VertexCreate;
PROCEDURE VertexDelete (<* UNUSED *> po : ParseObject;
<* UNUSED *> t : T;
elem: Elem ) =
BEGIN
NARROW(elem, Vertex).remove();
END VertexDelete;
PROCEDURE VertexGetId (<* UNUSED *> gpo : ParseObject;
<* UNUSED *> t : T;
elem: Elem ): INTEGER =
BEGIN
RETURN NARROW(elem, Vertex).id
END VertexGetId;
TYPE
VertexFieldType = {Shape, Pos, Size, Color, Label, Font, FontColor,
BorderWidth, BorderColor, ZOrder};
PROCEDURE VertexSetText (<* UNUSED *> gpo : ParseObject;
t : T;
elem : Elem;
field: INTEGER;
value: Texts )
RAISES {GEFError.T} =
VAR vertex := NARROW(elem, Vertex);
BEGIN
LOCK t.mu DO
CASE VAL(field, VertexFieldType) OF
| VertexFieldType.Label => vertex.setLabel(value[0])
| VertexFieldType.Font =>
vertex.setFont(GraphVBTExtras.WorldFontFromFont(
GEFClass.FontFromName(value[0])))
| VertexFieldType.Color =>
vertex.setColor(GEFClass.PaintOpFromColor(value[0]))
| VertexFieldType.FontColor =>
vertex.setFontColor(GEFClass.PaintOpFromColor(value[0]))
| VertexFieldType.BorderColor =>
vertex.setFontColor(GEFClass.PaintOpFromColor(value[0]))
ELSE
RAISE Fatal;
END;
END
END VertexSetText;
PROCEDURE VertexSetReal (<* UNUSED *> gpo : ParseObject;
t : T;
elem : Elem;
field: INTEGER;
value: Reals )
RAISES {GEFError.T} =
VAR vertex := NARROW(elem, Vertex);
BEGIN
LOCK t.mu DO
CASE VAL(field, VertexFieldType) OF
| VertexFieldType.Pos =>
vertex.posCovered := TRUE;
vertex.move(R2.T{value[0], value[1]});
vertex.posCovered := FALSE;
| VertexFieldType.Size =>
WITH size = R2.T{value[0], value[1]} DO
IF size[0] < 0.0 OR size[1] < 0.0 THEN
RAISE GEFError.T("Can't have vertex size < 0");
END;
vertex.setSize(size)
END;
| VertexFieldType.BorderWidth =>
WITH size = value[0] DO
IF size < 0.0 THEN
RAISE GEFError.T("Can't have vertex border width < 0");
END;
vertex.setBorder(value[0]);
END;
ELSE
RAISE Fatal;
END;
END
END VertexSetReal;
PROCEDURE VertexSetEnum (<* UNUSED *> gpo : ParseObject;
t : T;
elem : Elem;
field: INTEGER;
value: Ints )
RAISES {GEFError.T} =
VAR vertex := NARROW(elem, Vertex);
BEGIN
LOCK t.mu DO
CASE VAL(field, VertexFieldType) OF
| VertexFieldType.Shape =>
vertex.setShape(VAL(value[0], GraphVBT.VertexShape))
| VertexFieldType.ZOrder =>
CASE VAL(value[0], ZOrder) OF
| ZOrder.FgFront => vertex.toFront(GraphVBT.ZOrder.Foreground)
| ZOrder.FgBack => vertex.toBack(GraphVBT.ZOrder.Foreground)
| ZOrder.NormalFront => vertex.toFront(GraphVBT.ZOrder.Normal)
| ZOrder.NormalBack => vertex.toBack(GraphVBT.ZOrder.Normal)
| ZOrder.BgFront => vertex.toFront(GraphVBT.ZOrder.Background)
| ZOrder.BgBack => vertex.toBack(GraphVBT.ZOrder.Background)
END;
ELSE
RAISE Fatal;
END;
END
END VertexSetEnum;
CONST
VertexMinSize = R2.T{1.0, 1.0};
PROCEDURE VertexFinish (<* UNUSED *> gpo : VertexParseObject;
t : T;
vertexRA: REFANY ) =
VAR vertex := NARROW(vertexRA, Vertex);
BEGIN
IF t.showAllElements AND vertex.size = R2.Origin THEN
vertex.size := VertexMinSize;
END;
EVAL vertex.init();
vertex.initialized := TRUE;
CASE vertex.zOrder OF
| ZOrder.FgFront => vertex.toFront(GraphVBT.ZOrder.Foreground)
| ZOrder.FgBack => vertex.toBack(GraphVBT.ZOrder.Foreground)
| ZOrder.NormalFront => vertex.toFront(GraphVBT.ZOrder.Normal)
| ZOrder.NormalBack => vertex.toBack(GraphVBT.ZOrder.Normal)
| ZOrder.BgFront => vertex.toFront(GraphVBT.ZOrder.Background)
| ZOrder.BgBack => vertex.toBack(GraphVBT.ZOrder.Background)
END;
END VertexFinish;
PROCEDURE VertexIsType (<* UNUSED *> po: ParseObject; obj: REFANY):
BOOLEAN =
BEGIN
RETURN ISTYPE(obj, Vertex);
END VertexIsType;
******************************* Edge *****************************
REVEAL
Edge = EPublic BRANDED OBJECT
initialized := FALSE;
id : INTEGER;
zOrder : ZOrder;
OVERRIDES
move := EdgeMove;
setWidth := EdgeSetWidth;
setColor := EdgeSetColor;
setArrow := EdgeSetArrow;
toFront := EdgeToFront;
toBack := EdgeToBack;
END;
PROCEDURE EdgeMove(e: Edge; v0, v1, c0, c1: GraphVBT.Vertex; animated: BOOLEAN; start := 0.0; stop := 1.0) =
BEGIN
IF e.initialized THEN
GraphVBT.Edge.move(e, v0, v1, c0, c1, animated, start, stop);
ELSE
e.vertex0 := v0;
e.vertex1 := v1;
e.control0 := c0;
e.control1 := c1;
END;
END EdgeMove;
PROCEDURE EdgeSetWidth(e: Edge; w: REAL) =
BEGIN
IF e.initialized THEN
GraphVBT.Edge.setWidth(e, w)
ELSE
e.width := w;
END;
END EdgeSetWidth;
PROCEDURE EdgeSetColor(e: Edge; c: PaintOp.T) =
BEGIN
IF e.initialized THEN
GraphVBT.Edge.setColor(e, c)
ELSE
e.color := c;
END;
END EdgeSetColor;
PROCEDURE EdgeSetArrow(e: Edge; a: ARRAY [0 .. 1] OF BOOLEAN) =
BEGIN
IF e.initialized THEN
GraphVBT.Edge.setArrow(e, a)
ELSE
e.arrow := a;
END;
END EdgeSetArrow;
PROCEDURE EdgeToFront(t: Edge; zOrder: GraphVBT.ZOrder) =
BEGIN
IF t.initialized THEN
GraphVBT.Edge.toFront(t, zOrder);
ELSE
t.zOrder := front[zOrder]
END;
END EdgeToFront;
PROCEDURE EdgeToBack(t: Edge; zOrder: GraphVBT.ZOrder) =
BEGIN
IF t.initialized THEN
GraphVBT.Edge.toBack(t, zOrder);
ELSE
t.zOrder := back[zOrder]
END;
END EdgeToBack;
TYPE
EdgeParseObject = ParseObject OBJECT
OVERRIDES
create := EdgeCreate;
delete := EdgeDelete;
getId := EdgeGetId;
setBool := EdgeSetBool;
setText := EdgeSetText;
setElem := EdgeSetElem;
setInt := EdgeSetEnum;
setReal := EdgeSetReal;
finish := EdgeFinish;
isType := EdgeIsType;
END;
PROCEDURE EdgeCreate (<* UNUSED *> gpo: EdgeParseObject;
<* UNUSED *> t : T;
id : INTEGER ): REFANY =
BEGIN
RETURN NEW(Edge, id := id)
(* cannot call init here since edge needs vertices to be set before
init. Alternative could be to fix GraphVBT.InitEdge to ignore
edge, vertexHighlight, polygon if no vertices... *)
END EdgeCreate;
PROCEDURE EdgeDelete (<* UNUSED *> po : ParseObject;
<* UNUSED *> t : T;
elem: Elem ) =
BEGIN
NARROW(elem, Edge).remove();
END EdgeDelete;
PROCEDURE EdgeGetId (<* UNUSED *> gpo : ParseObject;
<* UNUSED *> t : T;
elem: Elem ): INTEGER =
BEGIN
RETURN NARROW(elem, Edge).id
END EdgeGetId;
TYPE
EdgeFieldType = {Vertices, Controls, Width, Color, Arrow, ZOrder};
PROCEDURE EdgeSetText (<* UNUSED *> gpo : ParseObject;
t : T;
elem : Elem;
field: INTEGER;
value: Texts ) RAISES {GEFError.T} =
VAR edge := NARROW(elem, Edge);
BEGIN
LOCK t.mu DO
CASE VAL(field, EdgeFieldType) OF
| EdgeFieldType.Color => edge.setColor(GEFClass.PaintOpFromColor(value[0]))
ELSE
RAISE Fatal;
END;
END;
END EdgeSetText;
PROCEDURE EdgeSetElem (<* UNUSED *> gpo : ParseObject;
t : T;
elem : Elem;
field: INTEGER;
value: Elems )
RAISES {GEFError.T} =
VAR
edge := NARROW(elem, Edge);
c0, c1: Vertex;
BEGIN
LOCK t.mu DO
CASE VAL(field, EdgeFieldType) OF
| EdgeFieldType.Vertices =>
IF NUMBER(value^) # 2 THEN
RAISE GEFError.T("Must give 2 elements for edge vertices");
ELSIF NOT ISTYPE(value[0], Vertex)
OR NOT ISTYPE(value[1], Vertex) THEN
RAISE
GEFError.T("Element given for edge vertex is not a Vertex");
END;
edge.move(value[0], value[1], edge.control0, edge.control1);
| EdgeFieldType.Controls =>
IF NUMBER(value^) # 2 THEN
c0 := NIL;
c1 := NIL;
ELSIF NOT ISTYPE(value[0], Vertex)
OR NOT ISTYPE(value[1], Vertex) THEN
RAISE
GEFError.T(
"Element given for edge control vertex is not a Vertex");
ELSE
c0 := value[0];
c1 := value[1];
END;
edge.move(edge.vertex0, edge.vertex1, c0, c1)
ELSE
RAISE Fatal;
END;
END;
END EdgeSetElem;
PROCEDURE EdgeSetEnum (<* UNUSED *> gpo : ParseObject;
t : T;
elem : Elem;
field: INTEGER;
value: Ints )
RAISES {GEFError.T} =
VAR edge := NARROW(elem, Edge);
BEGIN
LOCK t.mu DO
CASE VAL(field, EdgeFieldType) OF
| EdgeFieldType.ZOrder =>
CASE VAL(value[0], ZOrder) OF
| ZOrder.FgFront => edge.toFront(GraphVBT.ZOrder.Foreground)
| ZOrder.FgBack => edge.toBack(GraphVBT.ZOrder.Foreground)
| ZOrder.NormalFront => edge.toFront(GraphVBT.ZOrder.Normal)
| ZOrder.NormalBack => edge.toBack(GraphVBT.ZOrder.Normal)
| ZOrder.BgFront => edge.toFront(GraphVBT.ZOrder.Background)
| ZOrder.BgBack => edge.toBack(GraphVBT.ZOrder.Background)
END;
ELSE
RAISE Fatal;
END;
END
END EdgeSetEnum;
PROCEDURE EdgeSetReal (<* UNUSED *> gpo : ParseObject;
t : T;
elem : Elem;
field: INTEGER;
value: Reals ) RAISES {GEFError.T} =
VAR edge := NARROW(elem, Edge);
BEGIN
LOCK t.mu DO
CASE VAL(field, EdgeFieldType) OF
| EdgeFieldType.Width => edge.setWidth(value[0])
ELSE
RAISE Fatal;
END;
END;
END EdgeSetReal;
PROCEDURE EdgeSetBool (<* UNUSED *> gpo : ParseObject;
t : T;
elem : Elem;
field: INTEGER;
value: Bools ) RAISES {GEFError.T} =
VAR edge := NARROW(elem, Edge);
BEGIN
LOCK t.mu DO
CASE VAL(field, EdgeFieldType) OF
| EdgeFieldType.Arrow =>
edge.setArrow(ARRAY [0 .. 1] OF BOOLEAN{value[0], value[1]})
ELSE
RAISE Fatal;
END;
END;
END EdgeSetBool;
CONST
MinEdgeSize = 0.4;
PROCEDURE EdgeFinish (<* UNUSED *> gpo : EdgeParseObject;
t : T;
edgeRA: REFANY )
RAISES {GEFError.T} =
VAR edge := NARROW(edgeRA, Edge);
BEGIN
IF edge.vertex0 = NIL OR edge.vertex1 = NIL THEN
RAISE GEFError.T("Edge missing vertex")
END;
IF t.showAllElements AND edge.width = 0.0 THEN edge.width := MinEdgeSize END;
EVAL edge.init();
edge.initialized := TRUE;
CASE edge.zOrder OF
| ZOrder.FgFront => edge.toFront(GraphVBT.ZOrder.Foreground)
| ZOrder.FgBack => edge.toBack(GraphVBT.ZOrder.Foreground)
| ZOrder.NormalFront => edge.toFront(GraphVBT.ZOrder.Normal)
| ZOrder.NormalBack => edge.toBack(GraphVBT.ZOrder.Normal)
| ZOrder.BgFront => edge.toFront(GraphVBT.ZOrder.Background)
| ZOrder.BgBack => edge.toBack(GraphVBT.ZOrder.Background)
END;
END EdgeFinish;
PROCEDURE EdgeIsType (<* UNUSED *> po: ParseObject; obj: REFANY): BOOLEAN =
BEGIN
RETURN ISTYPE(obj, Edge);
END EdgeIsType;
***************************** Vertex Highlight ***********************
REVEAL
VertexHighlight = VHPublic BRANDED OBJECT
initialized := FALSE;
id : INTEGER;
zOrder : ZOrder;
OVERRIDES
move := HighlightMove;
setBorder := HighlightSetBorder;
setColor := HighlightSetColor;
toFront := HighlightToFront;
toBack := HighlightToBack;
END;
PROCEDURE HighlightMove (t : VertexHighlight;
vertex : GraphVBT.Vertex;
animated: BOOLEAN; start := 0.0; stop := 1.0 ) =
BEGIN
IF t.initialized THEN
GraphVBT.VertexHighlight.move(t, vertex, animated, start, stop)
ELSE
t.vertex := vertex;
END;
END HighlightMove;
PROCEDURE HighlightSetBorder (t: VertexHighlight; border: R2.T) =
BEGIN
IF t.initialized THEN
GraphVBT.VertexHighlight.setBorder(t, border);
ELSE
t.border := border;
END;
END HighlightSetBorder;
PROCEDURE HighlightSetColor (t: VertexHighlight; color: PaintOp.T) =
BEGIN
IF t.initialized THEN
GraphVBT.VertexHighlight.setColor(t, color)
ELSE
t.color := color;
END;
END HighlightSetColor;
PROCEDURE HighlightToFront(t: VertexHighlight; zOrder: GraphVBT.ZOrder) =
BEGIN
IF t.initialized THEN
GraphVBT.VertexHighlight.toFront(t, zOrder);
ELSE
t.zOrder := front[zOrder]
END;
END HighlightToFront;
PROCEDURE HighlightToBack(t: VertexHighlight; zOrder: GraphVBT.ZOrder) =
BEGIN
IF t.initialized THEN
GraphVBT.VertexHighlight.toBack(t, zOrder);
ELSE
t.zOrder := back[zOrder]
END;
END HighlightToBack;
TYPE
HighlightParseObject = ParseObject OBJECT
OVERRIDES
create := HighlightCreate;
delete := HighlightDelete;
getId := HighlightGetId;
setText := HighlightSetText;
setReal := HighlightSetReal;
setElem := HighlightSetElem;
setInt := HighlightSetEnum;
finish := HighlightFinish;
isType := HighlightIsType;
END;
PROCEDURE HighlightCreate (<* UNUSED *> gpo: HighlightParseObject;
<* UNUSED *> t : T;
id : INTEGER ):
REFANY =
BEGIN
RETURN NEW(VertexHighlight, id := id)
END HighlightCreate;
PROCEDURE HighlightDelete (<* UNUSED *> po : ParseObject;
<* UNUSED *> t : T;
elem: Elem ) =
BEGIN
NARROW(elem, VertexHighlight).remove();
END HighlightDelete;
PROCEDURE HighlightGetId (<* UNUSED *> gpo : ParseObject;
<* UNUSED *> t : T;
elem: Elem ): INTEGER =
BEGIN
RETURN NARROW(elem, VertexHighlight).id
END HighlightGetId;
TYPE
HighlightFieldType = {Vertex, Border, Color, ZOrder};
PROCEDURE HighlightSetText (<* UNUSED *> gpo : HighlightParseObject;
t : T;
elem : Elem;
field: INTEGER;
value: Texts )
RAISES {GEFError.T} =
VAR highlight := NARROW(elem, VertexHighlight);
BEGIN
LOCK t.mu DO
CASE VAL(field, HighlightFieldType) OF
| HighlightFieldType.Color =>
highlight.setColor(GEFClass.PaintOpFromColor(value[0]))
ELSE
RAISE Fatal;
END;
END;
END HighlightSetText;
PROCEDURE HighlightSetElem (<* UNUSED *> gpo : HighlightParseObject;
t : T;
elem : Elem;
field: INTEGER;
value: Elems )
RAISES {GEFError.T} =
VAR highlight := NARROW(elem, VertexHighlight);
BEGIN
LOCK t.mu DO
CASE VAL(field, HighlightFieldType) OF
| HighlightFieldType.Vertex =>
IF NUMBER(value^) # 1 OR NOT ISTYPE(value[0], Vertex) THEN
RAISE GEFError.T("Element given for highlight vertex is not a vertex")
END;
highlight.move(value[0]);
ELSE
RAISE Fatal;
END;
END;
END HighlightSetElem;
PROCEDURE HighlightSetEnum (<* UNUSED *> gpo : ParseObject;
t : T;
elem : Elem;
field: INTEGER;
value: Ints )
RAISES {GEFError.T} =
VAR highlight := NARROW(elem, VertexHighlight);
BEGIN
LOCK t.mu DO
CASE VAL(field, HighlightFieldType) OF
| HighlightFieldType.ZOrder =>
CASE VAL(value[0], ZOrder) OF
| ZOrder.FgFront => highlight.toFront(GraphVBT.ZOrder.Foreground)
| ZOrder.FgBack => highlight.toBack(GraphVBT.ZOrder.Foreground)
| ZOrder.NormalFront => highlight.toFront(GraphVBT.ZOrder.Normal)
| ZOrder.NormalBack => highlight.toBack(GraphVBT.ZOrder.Normal)
| ZOrder.BgFront => highlight.toFront(GraphVBT.ZOrder.Background)
| ZOrder.BgBack => highlight.toBack(GraphVBT.ZOrder.Background)
END;
ELSE
RAISE Fatal;
END;
END
END HighlightSetEnum;
PROCEDURE HighlightSetReal (<* UNUSED *> gpo : ParseObject;
t : T;
elem : Elem;
field: INTEGER;
value: Reals )
RAISES {GEFError.T} =
VAR highlight := NARROW(elem, VertexHighlight);
BEGIN
LOCK t.mu DO
CASE VAL(field, HighlightFieldType) OF
| HighlightFieldType.Border =>
highlight.setBorder(R2.T{value[0], value[1]})
ELSE
RAISE Fatal;
END;
END
END HighlightSetReal;
CONST
MinBorderSize = R2.T{1.0, 1.0};
PROCEDURE HighlightFinish (<* UNUSED *> gpo : ParseObject;
t : T;
highlightRA: REFANY )
RAISES {GEFError.T} =
VAR highlight := NARROW(highlightRA, VertexHighlight);
BEGIN
IF highlight.vertex = NIL THEN
RAISE GEFError.T("Highlight missing vertex")
END;
IF t.showAllElements AND highlight.border = R2.Origin THEN
highlight.border := MinBorderSize
END;
highlight.initialized := TRUE;
EVAL highlight.init();
CASE highlight.zOrder OF
| ZOrder.FgFront => highlight.toFront(GraphVBT.ZOrder.Foreground)
| ZOrder.FgBack => highlight.toBack(GraphVBT.ZOrder.Foreground)
| ZOrder.NormalFront => highlight.toFront(GraphVBT.ZOrder.Normal)
| ZOrder.NormalBack => highlight.toBack(GraphVBT.ZOrder.Normal)
| ZOrder.BgFront => highlight.toFront(GraphVBT.ZOrder.Background)
| ZOrder.BgBack => highlight.toBack(GraphVBT.ZOrder.Background)
END;
END HighlightFinish;
PROCEDURE HighlightIsType (<* UNUSED *> po: ParseObject; obj: REFANY):
BOOLEAN =
BEGIN
RETURN ISTYPE(obj, VertexHighlight);
END HighlightIsType;
********************************* Polygons ***********************
REVEAL
Polygon = PPublic BRANDED OBJECT
initialized := FALSE;
id : INTEGER;
zOrder : ZOrder;
OVERRIDES
move := PolygonMove;
setColor := PolygonSetColor;
toFront := PolygonToFront;
toBack := PolygonToBack;
END;
PROCEDURE PolygonMove (t : Polygon;
vertices: RefList.T;
animated: BOOLEAN;
start := 0.0;
stop := 1.0 ) =
BEGIN
IF t.initialized THEN
GraphVBT.Polygon.move(t, vertices, animated, start, stop);
ELSE
t.vertices := vertices;
END;
END PolygonMove;
PROCEDURE PolygonSetColor (t: Polygon; color: PaintOp.T) =
BEGIN
IF t.initialized THEN
GraphVBT.Polygon.setColor(t, color)
ELSE
t.color := color;
END;
END PolygonSetColor;
PROCEDURE PolygonToFront(t: Polygon; zOrder: GraphVBT.ZOrder) =
BEGIN
IF t.initialized THEN
GraphVBT.Polygon.toFront(t, zOrder);
ELSE
t.zOrder := front[zOrder]
END;
END PolygonToFront;
PROCEDURE PolygonToBack(t: Polygon; zOrder: GraphVBT.ZOrder) =
BEGIN
IF t.initialized THEN
GraphVBT.Polygon.toBack(t, zOrder);
ELSE
t.zOrder := back[zOrder]
END;
END PolygonToBack;
TYPE
PolygonParseObject = ParseObject OBJECT
OVERRIDES
create := PolygonCreate;
delete := PolygonDelete;
getId := PolygonGetId;
setText := PolygonSetText;
setElem := PolygonSetElem;
setInt := PolygonSetEnum;
finish := PolygonFinish;
isType := PolygonIsType;
END;
PROCEDURE PolygonCreate (<* UNUSED *> gpo: ParseObject;
<* UNUSED *> t : T;
id : INTEGER ): REFANY =
BEGIN
RETURN NEW(Polygon, id := id)
END PolygonCreate;
PROCEDURE PolygonDelete (<* UNUSED *> po : ParseObject;
<* UNUSED *> t : T;
elem: Elem ) =
BEGIN
NARROW(elem, Polygon).remove();
END PolygonDelete;
PROCEDURE PolygonGetId (<* UNUSED *> gpo : ParseObject;
<* UNUSED *> t : T;
elem: Elem ): INTEGER =
BEGIN
RETURN NARROW(elem, Polygon).id
END PolygonGetId;
TYPE
PolygonFieldType = {Vertices, Color, ZOrder};
PROCEDURE PolygonSetText (<* UNUSED *> gpo : ParseObject;
t : T;
elem : Elem;
field: INTEGER;
value: Texts )
RAISES {GEFError.T} =
VAR polygon := NARROW(elem, Polygon);
BEGIN
LOCK t.mu DO
CASE VAL(field, PolygonFieldType) OF
| PolygonFieldType.Color =>
polygon.setColor(GEFClass.PaintOpFromColor(value[0]))
ELSE
RAISE Fatal;
END;
END
END PolygonSetText;
PROCEDURE PolygonSetElem (<* UNUSED *> gpo : ParseObject;
t : T;
elem : Elem;
field: INTEGER;
value: Elems )
RAISES {GEFError.T} =
VAR
polygon := NARROW(elem, Polygon);
vertices: RefList.T;
BEGIN
LOCK t.mu DO
CASE VAL(field, PolygonFieldType) OF
| PolygonFieldType.Vertices =>
FOR i := 0 TO LAST(value^) DO
TYPECASE value[i] OF
| Vertex =>
| RefList.T (l) =>
IF i = 0 THEN
RAISE GEFError.T(
"First element of a polygon must be a Vertex, not a list");
END;
IF RefList.Length(l) = 3 THEN
FOR i := 0 TO 2 DO
IF NOT ISTYPE(RefList.Nth(l, i), Vertex) THEN
RAISE
GEFError.T(
Fmt.F(
"Element %s given in polygon vertex list is not a Vertex",
Fmt.Int(i)));
END;
END;
ELSE
RAISE
GEFError.T(
Fmt.F(
"Vertex list for a curved polygon edge has %s elements, but must have 3",
Fmt.Int(RefList.Length(l))));
END;
ELSE
RAISE GEFError.T(
"Element given for polygon vertex is not a Vertex");
END;
vertices := RefList.Cons(value[i], vertices);
END;
polygon.move(RefList.ReverseD(vertices));
ELSE
RAISE Fatal;
END;
END
END PolygonSetElem;
PROCEDURE PolygonSetEnum (<* UNUSED *> gpo : ParseObject;
t : T;
elem : Elem;
field: INTEGER;
value: Ints )
RAISES {GEFError.T} =
VAR polygon := NARROW(elem, Polygon);
BEGIN
LOCK t.mu DO
CASE VAL(field, PolygonFieldType) OF
| PolygonFieldType.ZOrder =>
CASE VAL(value[0], ZOrder) OF
| ZOrder.FgFront => polygon.toFront(GraphVBT.ZOrder.Foreground)
| ZOrder.FgBack => polygon.toBack(GraphVBT.ZOrder.Foreground)
| ZOrder.NormalFront => polygon.toFront(GraphVBT.ZOrder.Normal)
| ZOrder.NormalBack => polygon.toBack(GraphVBT.ZOrder.Normal)
| ZOrder.BgFront => polygon.toFront(GraphVBT.ZOrder.Background)
| ZOrder.BgBack => polygon.toBack(GraphVBT.ZOrder.Background)
END;
ELSE
RAISE Fatal;
END;
END
END PolygonSetEnum;
PROCEDURE PolygonFinish (<* UNUSED *> gpo : PolygonParseObject;
<* UNUSED *> t : T;
polygonRA: REFANY )
RAISES {GEFError.T} =
VAR polygon := NARROW(polygonRA, Polygon);
BEGIN
IF polygon.vertices = NIL THEN
RAISE GEFError.T("Polygon missing vertices")
END;
polygon.initialized := TRUE;
EVAL polygon.init();
CASE polygon.zOrder OF
| ZOrder.FgFront => polygon.toFront(GraphVBT.ZOrder.Foreground)
| ZOrder.FgBack => polygon.toBack(GraphVBT.ZOrder.Foreground)
| ZOrder.NormalFront => polygon.toFront(GraphVBT.ZOrder.Normal)
| ZOrder.NormalBack => polygon.toBack(GraphVBT.ZOrder.Normal)
| ZOrder.BgFront => polygon.toFront(GraphVBT.ZOrder.Background)
| ZOrder.BgBack => polygon.toBack(GraphVBT.ZOrder.Background)
END;
END PolygonFinish;
PROCEDURE PolygonIsType(<* UNUSED *> po: ParseObject; obj: REFANY): BOOLEAN =
BEGIN
RETURN ISTYPE(obj, Polygon);
END PolygonIsType;
REVEAL
Arc = ArcInternal BRANDED OBJECT
id : INTEGER;
center : Vertex;
radius : REAL;
start, stop : REAL;
a11, a12, a21, a22: REAL;
color : PaintOp.T;
width : REAL;
arrows : ARRAY [0 .. 1] OF BOOLEAN;
zOrder : ZOrder;
END;
TYPE
ArcParseObject = ParseObject OBJECT
OVERRIDES
create := ArcCreate;
delete := ArcDelete;
getId := ArcGetId;
setBool := ArcSetBool;
setText := ArcSetText;
setElem := ArcSetElem;
setInt := ArcSetEnum;
setReal := ArcSetReal;
finish := ArcFinish;
isType := ArcIsType;
END;
ArcFieldType = {Center, Radius, Angle, Transformation, Width, Color, Arrow, ZOrder};
PROCEDURE ArcCreate (<* UNUSED *> gpo: ParseObject;
<* UNUSED *> t : T;
id : INTEGER ): REFANY =
BEGIN
RETURN NEW(Arc, id := id)
END ArcCreate;
PROCEDURE ArcDelete (<* UNUSED *> po : ParseObject;
<* UNUSED *> t : T;
elem: Elem ) =
BEGIN
DeleteArc(elem);
END ArcDelete;
PROCEDURE ArcGetId (<* UNUSED *> gpo : ParseObject;
<* UNUSED *> t : T;
elem: Elem ): INTEGER =
BEGIN
TYPECASE elem OF
| Arc (arc) => RETURN arc.id
| ArcEdge (e) => RETURN e.arc.id
ELSE
RAISE Fatal;
END;
END ArcGetId;
PROCEDURE ArcSetText (<* UNUSED *> gpo : ParseObject;
t : T;
elem : Elem;
field: INTEGER;
value: Texts )
RAISES {GEFError.T} =
VAR arc := NARROW(elem, Arc);
BEGIN
LOCK t.mu DO
CASE VAL(field, ArcFieldType) OF
| ArcFieldType.Color =>
arc.color := GEFClass.PaintOpFromColor(value[0]);
IF arc.edges # NIL THEN
FOR i := 0 TO LAST(arc.edges^) DO
arc.edges[i].setColor(arc.color);
END;
END;
ELSE
RAISE Fatal;
END;
END
END ArcSetText;
PROCEDURE ArcSetElem (<* UNUSED *> gpo : ParseObject;
t : T;
elem : Elem;
field: INTEGER;
value: Elems )
RAISES {GEFError.T} =
VAR arc := NARROW(elem, Arc); remake:= FALSE;
BEGIN
LOCK t.mu DO
CASE VAL(field, ArcFieldType) OF
| ArcFieldType.Center =>
IF NUMBER(value^) # 1 OR NOT ISTYPE(value[0], Vertex) THEN
RAISE
GEFError.T("Element given for arc center is not a vertex")
END;
arc.center := value[0];
remake := arc.edges # NIL;
ELSE
RAISE Fatal;
END;
END;
IF remake THEN MakeArc(t, arc) END;
END ArcSetElem;
PROCEDURE ArcSetEnum (<* UNUSED *> gpo : ParseObject;
t : T;
elem : Elem;
field: INTEGER;
value: Ints )
RAISES {GEFError.T} =
VAR arc := NARROW(elem, Arc);
BEGIN
LOCK t.mu DO
CASE VAL(field, ArcFieldType) OF
| ArcFieldType.ZOrder =>
arc.zOrder := VAL(value[0], ZOrder);
ELSE
RAISE Fatal;
END;
END
END ArcSetEnum;
PROCEDURE ArcSetBool (<* UNUSED *> gpo : ParseObject;
t : T;
elem : Elem;
field: INTEGER;
value: Bools )
RAISES {GEFError.T} =
VAR arc := NARROW(elem, Arc);
BEGIN
LOCK t.mu DO
CASE VAL(field, ArcFieldType) OF
| ArcFieldType.Arrow =>
arc.arrows[0] := value[0];
arc.arrows[1] := value[1];
IF arc.edges # NIL THEN
IF NUMBER(arc.edges^) = 1 THEN
arc.edges[0].setArrow(arc.arrows);
ELSE
arc.edges[0].setArrow(
ARRAY [0 .. 1] OF BOOLEAN{value[0], FALSE});
arc.edges[LAST(arc.edges^)].setArrow(
ARRAY [0 .. 1] OF BOOLEAN{FALSE, value[1]});
END;
END;
ELSE
RAISE Fatal;
END;
END
END ArcSetBool;
PROCEDURE ArcSetReal (<* UNUSED *> gpo : ParseObject;
t : T;
elem : Elem;
field: INTEGER;
value: Reals )
RAISES {GEFError.T} =
VAR
arc := NARROW(elem, Arc);
remake := FALSE;
BEGIN
LOCK t.mu DO
CASE VAL(field, ArcFieldType) OF
| ArcFieldType.Radius =>
arc.radius := value[0];
remake := arc.edges # NIL;
| ArcFieldType.Angle =>
arc.start := value[0];
arc.stop := value[1];
remake := arc.edges # NIL;
| ArcFieldType.Transformation =>
arc.a11 := value[0];
arc.a12 := value[1];
arc.a21 := value[2];
arc.a22 := value[3];
remake := arc.edges # NIL;
| ArcFieldType.Width =>
arc.width := value[0];
IF arc.edges # NIL THEN
FOR i := 0 TO LAST(arc.edges^) DO
arc.edges[i].setWidth(arc.width);
END;
END;
ELSE
RAISE Fatal;
END;
END;
IF remake THEN MakeArc(t, arc) END;
END ArcSetReal;
CONST
Epsilon = 0.001;
PROCEDURE ArcFinish (<* UNUSED *> po: ParseObject; t: T; elem: Elem)
RAISES {GEFError.T} =
VAR arc := NARROW(elem, Arc);
BEGIN
IF arc.center = NIL THEN RAISE GEFError.T("Arc missing center") END;
MakeArc(t, arc);
END ArcFinish;
PROCEDURE DeleteArc(arc: Arc) =
BEGIN
IF arc.edges # NIL THEN
FOR i := 0 TO LAST(arc.edges^) DO
arc.edges[i].remove();
END;
arc.edges := NIL;
END;
END DeleteArc;
PROCEDURE MakeArc(t: T; arc: Arc) =
VAR
start := arc.start;
stop := arc.stop;
deg : REAL;
qstart, qend: INTEGER;
BEGIN
DeleteArc(arc);
deg := ABS(stop - start);
IF deg <= 90.0 THEN
arc.edges := NEW(Edges, 1);
arc.edges[0] := MakeArcEdge(t, arc, start, stop);
ELSIF deg < 180.0 THEN
arc.edges := NEW(Edges, 2);
arc.edges[0] := MakeArcEdge(t, arc, start, (stop + start) / 2.0);
arc.edges[1] := MakeArcEdge(t, arc, (stop + start) / 2.0, stop);
ELSIF stop > start THEN
qstart := CEILING((start + Epsilon) / 90.0);
qend := FLOOR((stop - Epsilon) / 90.0);
arc.edges := NEW(Edges, 2 + qend - qstart);
arc.edges[0] := MakeArcEdge(t, arc, start, FLOAT(qstart) * 90.0);
FOR i := qstart TO MIN(qend, qstart+4) - 1 DO
arc.edges[1 + i - qstart] :=
MakeArcEdge(t, arc, FLOAT(i) * 90.0, FLOAT(i + 1) * 90.0);
END;
(* for multiple rotations, reuse paths *)
FOR i := 4 TO qend - qstart DO
arc.edges[i + 1] := arc.edges[i - 3]
END;
arc.edges[1 + qend - qstart] :=
MakeArcEdge(t, arc, FLOAT(qend) * 90.0, stop);
ELSE
qstart := FLOOR((start - Epsilon) / 90.0);
qend := CEILING((stop + Epsilon) / 90.0);
arc.edges := NEW(Edges, 2 + qstart - qend);
arc.edges[0] := MakeArcEdge(t, arc, start, FLOAT(qstart) * 90.0);
FOR i := qstart TO MAX(qend, qstart-4) + 1 BY -1 DO
arc.edges[1 + i - qstart] :=
MakeArcEdge(t, arc, FLOAT(i) * 90.0, FLOAT(i - 1) * 90.0);
END;
(* for multiple rotations, reuse paths *)
FOR i := 4 TO qstart - qend DO
arc.edges[i + 1] := arc.edges[i - 3]
END;
arc.edges[1 + qend - qstart] :=
MakeArcEdge(t, arc, FLOAT(qend) * 90.0, stop);
END;
END MakeArc;
ABS(stop - start) <= 90.0
PROCEDURE MakeArcEdge (t: T; arc: Arc; start, stop: REAL): ArcEdge =
VAR
edge := NEW(
ArcEdge, arc := arc, width := arc.width, color := arc.color);
v0, v1, c0, c1: R2.T;
theta : LONGREAL;
x : REAL;
BEGIN
(* make angles counter-clockwise rather than clockwise *)
start := -start;
stop := -stop;
theta := FLOAT(ABS(stop - start) * Math.Degree, LONGREAL);
IF ABS(theta) < 0.001d0 THEN
(* shouldn't happen? *)
edge.vertex0 := NEW(GraphVBT.Vertex, graph := t).init();
edge.vertex1 := edge.vertex0;
EVAL edge.init();
CASE arc.zOrder OF
| ZOrder.FgFront => edge.toFront(GraphVBT.ZOrder.Foreground)
| ZOrder.FgBack => edge.toBack(GraphVBT.ZOrder.Foreground)
| ZOrder.NormalFront => edge.toFront(GraphVBT.ZOrder.Normal)
| ZOrder.NormalBack => edge.toBack(GraphVBT.ZOrder.Normal)
| ZOrder.BgFront => edge.toFront(GraphVBT.ZOrder.Background)
| ZOrder.BgBack => edge.toBack(GraphVBT.ZOrder.Background)
END;
RETURN edge
ELSE
(* old calculation for mid-point of bezier lying on the arc WITH d =
1.0d0 - Math.cos(theta) DO x := FLOAT(4.0d0 / 3.0d0 *
(Math.sqrt(2.0d0 * d) - Math.sin(theta)) / d); END; *)
(* have pts 0.3373 and 0.6627 along the bezier lie on arc (values
from Lyle Ramshaw)
formula for x based on theta (from Maple with help from Andre
Broder) *)
WITH s = Math.sin(theta),
c = Math.cos(theta) DO
x := FLOAT((-1.89411484d0 * s
+ Math.sqrt(
(1.0588516d0 * c + 7.89411484d0) * (1.0d0 - c)))
/ (3.0d0 * (0.55294258d0 - 0.44705742d0 * c)));
END;
IF start > stop THEN x := -x END;
v0 := Pt(start);
v1 := Pt(stop);
c0 := R2.Add(v0, R2.Scale(x, R2.T{-v0[1], v0[0]}));
c1 := R2.Add(v1, R2.Scale(x, R2.T{v1[1], -v1[0]}));
END;
edge.vertex0 :=
NEW(GraphVBT.Vertex, pos := Xform(arc, v0), graph := t).init();
edge.vertex1 :=
NEW(GraphVBT.Vertex, pos := Xform(arc, v1), graph := t).init();
edge.control0 :=
NEW(GraphVBT.Vertex, pos := Xform(arc, c0), graph := t).init();
edge.control1 :=
NEW(GraphVBT.Vertex, pos := Xform(arc, c1), graph := t).init();
EVAL edge.init();
CASE arc.zOrder OF
| ZOrder.FgFront => edge.toFront(GraphVBT.ZOrder.Foreground)
| ZOrder.FgBack => edge.toBack(GraphVBT.ZOrder.Foreground)
| ZOrder.NormalFront => edge.toFront(GraphVBT.ZOrder.Normal)
| ZOrder.NormalBack => edge.toBack(GraphVBT.ZOrder.Normal)
| ZOrder.BgFront => edge.toFront(GraphVBT.ZOrder.Background)
| ZOrder.BgBack => edge.toBack(GraphVBT.ZOrder.Background)
END;
RETURN edge
END MakeArcEdge;
<* INLINE *>
PROCEDURE Pt (ang: REAL): R2.T =
VAR theta := FLOAT(ang * Math.Degree, LONGREAL);
BEGIN
RETURN R2.T{FLOAT(Math.cos(theta)), FLOAT(Math.sin(theta))};
END Pt;
PROCEDURE Xform(arc: Arc; pt: R2.T): R2.T =
VAR x := pt[0] * arc.radius; y := pt[1] * arc.radius;
BEGIN
RETURN R2.T{arc.a11 * x + arc.a12 * y + arc.center.pos[0],
arc.a21 * x + arc.a22 * y + arc.center.pos[1]}
END Xform;
PROCEDURE ArcIsType(<* UNUSED *> po: ParseObject; obj: REFANY): BOOLEAN =
BEGIN
RETURN ISTYPE(obj, Arc) OR ISTYPE(obj, ArcEdge);
END ArcIsType;
CONST
ZOrders = "(FgFront FgBack NormalFront NormalBack BgFront BgBack)";
front = ARRAY GraphVBT.ZOrder OF
ZOrder{ZOrder.FgFront, ZOrder.NormalFront, ZOrder.BgFront};
back = ARRAY GraphVBT.ZOrder OF
ZOrder{ZOrder.FgBack, ZOrder.NormalBack, ZOrder.BgBack};
TYPE
ZOrder = {FgFront, FgBack, NormalFront, NormalBack, BgFront, BgBack};
BEGIN
GEFClass.RegisterParseObject(
NEW(
GraphParseObject,
args :=
"((Name Graph)"
& Fmt.F(
"(Field %s World Real 4 (west east north south) (0.0 1.0 0.0 1.0))",
Fmt.Int(ORD(GraphFieldType.World)))
& Fmt.F("(Field %s Margin Real 1 () (0.0))",
Fmt.Int(ORD(GraphFieldType.Margin)))
& Fmt.F("(Field %s PixelSizeDivisor Integer 2 (hor ver) (1 1))",
Fmt.Int(ORD(GraphFieldType.PixelSizeDivisor)))
& Fmt.F("(Field %s Aspect Real 1 () (0.0))",
Fmt.Int(ORD(GraphFieldType.Aspect)))
& Fmt.F(
"(Field %s PrefSize Real 2 (width height) (100.0 100.0))",
Fmt.Int(ORD(GraphFieldType.PrefSize)))
& Fmt.F("(Field %s ClientData Sx 1 () (0.0))",
Fmt.Int(ORD(GraphFieldType.ClientData)))
& Fmt.F("(Field %s Contents Elem Infinity () ()))",
Fmt.Int(ORD(GraphFieldType.Contents)))));
GEFClass.RegisterParseObject(
NEW(
VertexParseObject,
args :=
"((Name Vertex)"
& Fmt.F("(Field %s Shape (Rectangle Ellipse) 1 () (Rectangle))",
Fmt.Int(ORD(VertexFieldType.Shape)))
& Fmt.F("(Field %s Pos Real 2 (x y) (0.0 0.0))",
Fmt.Int(ORD(VertexFieldType.Pos)))
& Fmt.F("(Field %s Size Real 2 (width height) (0.0 0.0))",
Fmt.Int(ORD(VertexFieldType.Size)))
& Fmt.F("(Field %s Color ColorSpec 1 () (Fg))",
Fmt.Int(ORD(VertexFieldType.Color)))
& Fmt.F("(Field %s ZOrder %s 1 () (NormalFront))",
Fmt.Int(ORD(VertexFieldType.ZOrder)), ZOrders)
& Fmt.F("(Field %s Label Text 1 () ())",
Fmt.Int(ORD(VertexFieldType.Label)))
& Fmt.F("(Field %s Font FontSpec 1 () (BuiltIn))",
Fmt.Int(ORD(VertexFieldType.Font)))
& Fmt.F("(Field %s FontColor ColorSpec 1 () (Fg))",
Fmt.Int(ORD(VertexFieldType.FontColor)))
& Fmt.F("(Field %s BorderWidth Real 1 () (0.0))",
Fmt.Int(ORD(VertexFieldType.BorderWidth)))
(*| FontColor is used in GraphVBT for BorderColor
& Fmt.F("(Field %s BorderColor ColorSpec 1 () (Black)))",
Fmt.Int(ORD(VertexFieldType.BorderColor)))
*)
& ")"
));
GEFClass.RegisterParseObject(
NEW(
EdgeParseObject,
args :=
"((Name Edge)"
& Fmt.F("(Field %s Vertices Elem 2 (vertex0 vertex1) ())",
Fmt.Int(ORD(EdgeFieldType.Vertices)))
& Fmt.F("(Field %s Controls Elem 2 (control0 control1) ())",
Fmt.Int(ORD(EdgeFieldType.Controls)))
& Fmt.F("(Field %s Width Real 1 () (0.007))",
Fmt.Int(ORD(EdgeFieldType.Width)))
& Fmt.F("(Field %s Color ColorSpec 1 () (Fg))",
Fmt.Int(ORD(EdgeFieldType.Color)))
& Fmt.F("(Field %s ZOrder %s 1 () (NormalFront))",
Fmt.Int(ORD(EdgeFieldType.ZOrder)), ZOrders)
& Fmt.F("(Field %s Arrows Boolean 2 (vertex0 vertex1) (FALSE FALSE)))",
Fmt.Int(ORD(EdgeFieldType.Arrow)))));
GEFClass.RegisterParseObject(
NEW(HighlightParseObject,
args :=
"((Name VertexHighlight)"
& Fmt.F("(Field %s Vertex Elem 1 () ())",
Fmt.Int(ORD(HighlightFieldType.Vertex)))
& Fmt.F("(Field %s Border Real 2 (width height) (0.0 0.0))",
Fmt.Int(ORD(HighlightFieldType.Border)))
& Fmt.F("(Field %s ZOrder %s 1 () (NormalFront))",
Fmt.Int(ORD(HighlightFieldType.ZOrder)), ZOrders)
& Fmt.F("(Field %s Color ColorSpec 1 () (Fg)))",
Fmt.Int(ORD(HighlightFieldType.Color)))));
GEFClass.RegisterParseObject(
NEW(PolygonParseObject,
args := "((Name Polygon)"
& Fmt.F("(Field %s Vertices Elem Infinity () ())",
Fmt.Int(ORD(PolygonFieldType.Vertices)))
& Fmt.F("(Field %s ZOrder %s 1 () (NormalFront))",
Fmt.Int(ORD(PolygonFieldType.ZOrder)), ZOrders)
& Fmt.F("(Field %s Color ColorSpec 1 () (Fg)))",
Fmt.Int(ORD(PolygonFieldType.Color)))));
GEFClass.RegisterParseObject(
NEW(
ArcParseObject,
args :=
"((Name Arc)"
& Fmt.F("(Field %s Center Elem 1 () ())",
Fmt.Int(ORD(ArcFieldType.Center)))
& Fmt.F("(Field %s Radius Real 1 () (1.0))",
Fmt.Int(ORD(ArcFieldType.Radius)))
& Fmt.F("(Field %s Angle Real 2 (start stop) (0.0 360.0))",
Fmt.Int(ORD(ArcFieldType.Angle)))
& Fmt.F("(Field %s Transformation Real 4 (a11 a12 a21 a22) (1.0 0.0 0.0 1.0))",
Fmt.Int(ORD(ArcFieldType.Transformation)))
& Fmt.F("(Field %s Width Real 1 () (0.007))",
Fmt.Int(ORD(ArcFieldType.Width)))
& Fmt.F("(Field %s Color ColorSpec 1 () (Fg))",
Fmt.Int(ORD(ArcFieldType.Color)))
& Fmt.F("(Field %s ZOrder %s 1 () (NormalFront))",
Fmt.Int(ORD(ArcFieldType.ZOrder)), ZOrders)
& Fmt.F("(Field %s Arrow Boolean 2 (first last) (FALSE FALSE)))",
Fmt.Int(ORD(ArcFieldType.Arrow)))));
END GEF.