Copyright (C) 1994, Digital Equipment Corp.
MODULE******************** Initialization ******************************GEF EXPORTSGEF ,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);
PROCEDURE******************************* Misc *******************************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; PROCEDUREInitFromText (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; PROCEDUREInitFromRsrc (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}; PROCEDURERead (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; PROCEDUREInitFromRd (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; PROCEDUREInitFromSx (t : T; sx : S_exp; showAllElements: BOOLEAN ) RAISES {GEFError.T, Thread.Alerted} = BEGIN LOCK mu DO GEFClass.Parse(t, sx, showAllElements); END; END InitFromSx;
PROCEDURE********************************* Graph **********************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; PROCEDUREAddElem (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; PROCEDURERedisplayImage (t: T) = BEGIN t.redisplay(); END RedisplayImage;
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************************************** Vertex ****************************GraphCreate (<* UNUSED *> gpo: ParseObject; t: T; id: INTEGER): S_exp = BEGIN t.id := id; RETURN t; END GraphCreate; PROCEDUREGraphDelete (<* UNUSED *> po : ParseObject; <* UNUSED *> t : T; <* UNUSED *> elem: Elem ) = BEGIN END GraphDelete; PROCEDUREGraphGetId (<* UNUSED *> gpo : ParseObject; t : T; <* UNUSED *> elem: Elem ): INTEGER = BEGIN RETURN t.id END GraphGetId; TYPE GraphFieldType = {World, Margin, PixelSizeDivisor, Aspect, PrefSize, ClientData, Contents}; PROCEDUREGraphSetReal (<* 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; PROCEDUREGraphSetInt (<* 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; PROCEDUREGraphSetElem (<* 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; PROCEDUREGraphFinish (<* UNUSED *> gpo : ParseObject; t : T; <* UNUSED *> graphRA: REFANY ) RAISES {GEFError.T} = BEGIN VBT.Mark(t); END GraphFinish; PROCEDUREGraphIsType (<* UNUSED *> po: ParseObject; obj: REFANY): BOOLEAN = BEGIN RETURN ISTYPE(obj, T); END GraphIsType;
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******************************* Edge *****************************NewPos (pos: R2.T): GEFClass.Reals = VAR res := NEW(GEFClass.Reals, 2); BEGIN res^ := pos; RETURN res; END NewPos; PROCEDUREVertexSetPos (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; PROCEDUREVertexSetSize (t: Vertex; size: R2.T) = BEGIN IF t.initialized THEN GraphVBT.Vertex.setSize(t, size); ELSE t.size := size; END; END VertexSetSize; PROCEDUREVertexSetShape (t: Vertex; shape: GraphVBT.VertexShape) = BEGIN IF t.initialized THEN GraphVBT.Vertex.setShape(t, shape); ELSE t.shape := shape; END; END VertexSetShape; PROCEDUREVertexSetColor (t: Vertex; color: PaintOp.T) = BEGIN IF t.initialized THEN GraphVBT.Vertex.setColor(t, color); ELSE t.color := color; END; END VertexSetColor; PROCEDUREVertexSetLabel (t: Vertex; v: TEXT) = BEGIN IF t.initialized THEN GraphVBT.Vertex.setLabel(t, v); ELSE t.label := v; END; END VertexSetLabel; PROCEDUREVertexSetFont (t: Vertex; v: GraphVBT.WorldFont) = BEGIN IF t.initialized THEN GraphVBT.Vertex.setFont(t, v); ELSE t.font := v; END; END VertexSetFont; PROCEDUREVertexSetFontColor (t: Vertex; v: PaintOp.T) = BEGIN IF t.initialized THEN GraphVBT.Vertex.setFontColor(t, v); ELSE t.fontColor := v; END; END VertexSetFontColor; PROCEDUREVertexSetBorder (t: Vertex; v: REAL) = BEGIN IF t.initialized THEN GraphVBT.Vertex.setBorder(t, v); ELSE t.border := v; END; END VertexSetBorder; PROCEDUREVertexSetBorderColor (t: Vertex; v: PaintOp.T) = BEGIN IF t.initialized THEN GraphVBT.Vertex.setBorderColor(t, v); ELSE t.fontColor := v; END; END VertexSetBorderColor; PROCEDUREVertexToFront (t: Vertex; zOrder: GraphVBT.ZOrder) = BEGIN IF t.initialized THEN GraphVBT.Vertex.toFront(t, zOrder); ELSE t.zOrder := front[zOrder] END; END VertexToFront; PROCEDUREVertexToBack (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; PROCEDUREVertexCreate (<* UNUSED *> gpo: VertexParseObject; t : T; id : INTEGER ): REFANY = BEGIN RETURN NEW(Vertex, graph := t, id := id) END VertexCreate; PROCEDUREVertexDelete (<* UNUSED *> po : ParseObject; <* UNUSED *> t : T; elem: Elem ) = BEGIN NARROW(elem, Vertex).remove(); END VertexDelete; PROCEDUREVertexGetId (<* 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}; PROCEDUREVertexSetText (<* 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; PROCEDUREVertexSetReal (<* 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; PROCEDUREVertexSetEnum (<* 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}; PROCEDUREVertexFinish (<* 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; PROCEDUREVertexIsType (<* UNUSED *> po: ParseObject; obj: REFANY): BOOLEAN = BEGIN RETURN ISTYPE(obj, Vertex); END VertexIsType;
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***************************** Vertex Highlight ***********************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; PROCEDUREEdgeSetWidth (e: Edge; w: REAL) = BEGIN IF e.initialized THEN GraphVBT.Edge.setWidth(e, w) ELSE e.width := w; END; END EdgeSetWidth; PROCEDUREEdgeSetColor (e: Edge; c: PaintOp.T) = BEGIN IF e.initialized THEN GraphVBT.Edge.setColor(e, c) ELSE e.color := c; END; END EdgeSetColor; PROCEDUREEdgeSetArrow (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; PROCEDUREEdgeToFront (t: Edge; zOrder: GraphVBT.ZOrder) = BEGIN IF t.initialized THEN GraphVBT.Edge.toFront(t, zOrder); ELSE t.zOrder := front[zOrder] END; END EdgeToFront; PROCEDUREEdgeToBack (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; PROCEDUREEdgeCreate (<* 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; PROCEDUREEdgeDelete (<* UNUSED *> po : ParseObject; <* UNUSED *> t : T; elem: Elem ) = BEGIN NARROW(elem, Edge).remove(); END EdgeDelete; PROCEDUREEdgeGetId (<* 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}; PROCEDUREEdgeSetText (<* 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; PROCEDUREEdgeSetElem (<* 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; PROCEDUREEdgeSetEnum (<* 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; PROCEDUREEdgeSetReal (<* 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; PROCEDUREEdgeSetBool (<* 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; PROCEDUREEdgeFinish (<* 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; PROCEDUREEdgeIsType (<* UNUSED *> po: ParseObject; obj: REFANY): BOOLEAN = BEGIN RETURN ISTYPE(obj, Edge); END EdgeIsType;
REVEAL VertexHighlight = VHPublic BRANDED OBJECT initialized := FALSE; id : INTEGER; zOrder : ZOrder; OVERRIDES move := HighlightMove; setBorder := HighlightSetBorder; setColor := HighlightSetColor; toFront := HighlightToFront; toBack := HighlightToBack; END; PROCEDURE********************************* Polygons ***********************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; PROCEDUREHighlightSetBorder (t: VertexHighlight; border: R2.T) = BEGIN IF t.initialized THEN GraphVBT.VertexHighlight.setBorder(t, border); ELSE t.border := border; END; END HighlightSetBorder; PROCEDUREHighlightSetColor (t: VertexHighlight; color: PaintOp.T) = BEGIN IF t.initialized THEN GraphVBT.VertexHighlight.setColor(t, color) ELSE t.color := color; END; END HighlightSetColor; PROCEDUREHighlightToFront (t: VertexHighlight; zOrder: GraphVBT.ZOrder) = BEGIN IF t.initialized THEN GraphVBT.VertexHighlight.toFront(t, zOrder); ELSE t.zOrder := front[zOrder] END; END HighlightToFront; PROCEDUREHighlightToBack (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; PROCEDUREHighlightCreate (<* UNUSED *> gpo: HighlightParseObject; <* UNUSED *> t : T; id : INTEGER ): REFANY = BEGIN RETURN NEW(VertexHighlight, id := id) END HighlightCreate; PROCEDUREHighlightDelete (<* UNUSED *> po : ParseObject; <* UNUSED *> t : T; elem: Elem ) = BEGIN NARROW(elem, VertexHighlight).remove(); END HighlightDelete; PROCEDUREHighlightGetId (<* UNUSED *> gpo : ParseObject; <* UNUSED *> t : T; elem: Elem ): INTEGER = BEGIN RETURN NARROW(elem, VertexHighlight).id END HighlightGetId; TYPE HighlightFieldType = {Vertex, Border, Color, ZOrder}; PROCEDUREHighlightSetText (<* 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; PROCEDUREHighlightSetElem (<* 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; PROCEDUREHighlightSetEnum (<* 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; PROCEDUREHighlightSetReal (<* 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}; PROCEDUREHighlightFinish (<* 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; PROCEDUREHighlightIsType (<* UNUSED *> po: ParseObject; obj: REFANY): BOOLEAN = BEGIN RETURN ISTYPE(obj, VertexHighlight); END HighlightIsType;
REVEAL Polygon = PPublic BRANDED OBJECT initialized := FALSE; id : INTEGER; zOrder : ZOrder; OVERRIDES move := PolygonMove; setColor := PolygonSetColor; toFront := PolygonToFront; toBack := PolygonToBack; END; PROCEDUREABS(stop - start) <= 90.0PolygonMove (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; PROCEDUREPolygonSetColor (t: Polygon; color: PaintOp.T) = BEGIN IF t.initialized THEN GraphVBT.Polygon.setColor(t, color) ELSE t.color := color; END; END PolygonSetColor; PROCEDUREPolygonToFront (t: Polygon; zOrder: GraphVBT.ZOrder) = BEGIN IF t.initialized THEN GraphVBT.Polygon.toFront(t, zOrder); ELSE t.zOrder := front[zOrder] END; END PolygonToFront; PROCEDUREPolygonToBack (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; PROCEDUREPolygonCreate (<* UNUSED *> gpo: ParseObject; <* UNUSED *> t : T; id : INTEGER ): REFANY = BEGIN RETURN NEW(Polygon, id := id) END PolygonCreate; PROCEDUREPolygonDelete (<* UNUSED *> po : ParseObject; <* UNUSED *> t : T; elem: Elem ) = BEGIN NARROW(elem, Polygon).remove(); END PolygonDelete; PROCEDUREPolygonGetId (<* UNUSED *> gpo : ParseObject; <* UNUSED *> t : T; elem: Elem ): INTEGER = BEGIN RETURN NARROW(elem, Polygon).id END PolygonGetId; TYPE PolygonFieldType = {Vertices, Color, ZOrder}; PROCEDUREPolygonSetText (<* 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; PROCEDUREPolygonSetElem (<* 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; PROCEDUREPolygonSetEnum (<* 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; PROCEDUREPolygonFinish (<* 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; PROCEDUREPolygonIsType (<* 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}; PROCEDUREArcCreate (<* UNUSED *> gpo: ParseObject; <* UNUSED *> t : T; id : INTEGER ): REFANY = BEGIN RETURN NEW(Arc, id := id) END ArcCreate; PROCEDUREArcDelete (<* UNUSED *> po : ParseObject; <* UNUSED *> t : T; elem: Elem ) = BEGIN DeleteArc(elem); END ArcDelete; PROCEDUREArcGetId (<* 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; PROCEDUREArcSetText (<* 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; PROCEDUREArcSetElem (<* 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; PROCEDUREArcSetEnum (<* 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; PROCEDUREArcSetBool (<* 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; PROCEDUREArcSetReal (<* 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; PROCEDUREArcFinish (<* 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; PROCEDUREDeleteArc (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; PROCEDUREMakeArc (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;
PROCEDUREMakeArcEdge (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 *> PROCEDUREPt (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; PROCEDUREXform (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; PROCEDUREArcIsType (<* 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.