gef/src/GEF.m3


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.

interface Filename is in:


interface Math is in: