sugiyamalayout.pas

ESS-Model is a powerful, reverse engine, UML-tool for Delphi/Kylix and Java-files.

var
  Node : TNode;
  I,J : integer;
  Highest,Y : integer;
begin
  Y := 40;
  for I := 0 to Layers.Count-1 do
  begin
    //Put all nodes in a layer with the same Y, increase Y with highest node + spacing
    Highest := 0;
    for J := 0 to Layers[I].Count-1 do
    begin
      Node := Layers[I][J];
      Highest := Max(Node.H,Highest);
      Node.Y := Y;
    end;
    Inc(Y,Highest + VSpacing);
  end;
end;


procedure TSugiyamaLayout.SetXPositions;
const
  HSpacing = 20;
  MaxIter = 20;
var
  I,J,X,Z,OldZ,BailOut,RegStart,RegCount,MaxAmount,Amount : integer;
  Force,LastForce,RegForce : single;
  Layer : TNodeList;
  Node : TNode;
  Forces : array of single;

  function InCenter(const Node : TNode) : integer;
  begin
    Result := Node.X + Node.W div 2;
  end;

  function InForce(const Node : TNode) : single;
  var
    Sum : integer;
    I,Deg,CenterX : integer;
  begin
    Deg := Node.InEdges.Count + Node.OutEdges.Count;
    if Deg=0 then
    begin
      Result := 0;
      Exit;
    end;
    Sum := 0;
    CenterX := InCenter(Node);
    for I := 0 to Node.InEdges.Count-1 do
      Inc(Sum, InCenter(Node.InEdges[I].FromNode) - CenterX );
    for I := 0 to Node.OutEdges.Count-1 do
      Inc(Sum, InCenter(Node.OutEdges[I].ToNode) - CenterX );
    Inc(Z, Abs(Sum) );
    Result := (1 / Deg) * Sum;
  end;

begin
  //Initialize X for each node based on its position within the layer
  for I := 0 to Layers.Count-1 do
  begin
    Layer := Layers[I];
    X := HSpacing;
    for J := 0 to Layer.Count-1 do
    begin
      Node := Layer[J];
      Node.X := X;
      Inc(X,HSpacing + Node.W);
    end;
  end;

  BailOut := 0;
  OldZ := High(Integer);
  repeat
    Inc(BailOut);
    //Z is the sum of differences between all node.x and node.desired_X
    Z := 0;
    for I := 0 to Layers.Count-1 do
    begin
      Layer := Layers[I];

      SetLength(Forces,Layer.Count);
      for J := 0 to Layer.Count-1 do
        Forces[J] := InForce(Layer[J]);

      //Calc regions of nodes so that two neibours do not block each other out
      RegStart:=0;
      while RegStart<Layer.Count do
      begin
        LastForce := Forces[RegStart];
        RegForce := LastForce;
        RegCount := 1;
        J := RegStart + 1;
        //"Touching" nodes with higher force belongs to the same group
        while (J < Layer.Count) and (LastForce >= Forces[J]) and
          (Layer[J].X - (Layer[J-1].X + Layer[J-1].W) <= HSpacing) do
        begin
          LastForce := Forces[J];
          RegForce := RegForce + LastForce;
          Inc(J);
          Inc(RegCount);
        end;
        Force := 1/RegCount * RegForce;

        if Force<>0 then
        begin
          if Force<0 then
          begin
            //Move region left
            if RegStart=0 then
              MaxAmount := Layer[RegStart].X - HSpacing
            else //Cannot move over node to the left
              MaxAmount := Layer[RegStart].X - (Layer[RegStart-1].X + Layer[RegStart-1].W + HSpacing);
            Amount := -Min( Abs(Round(Force)) , MaxAmount );
          end
          else
          begin
            //Move region right
            if RegStart + RegCount = Layer.Count then
              MaxAmount := High(Integer)
            else //Cannot move over node to the right
              MaxAmount := Layer[RegStart + RegCount].X -
                (Layer[ RegStart + RegCount - 1 ].X + Layer[ RegStart + RegCount - 1 ].W + HSpacing);
            Amount := Min( Round(Force) , MaxAmount );
          end;

          //Move nodes in region
          if Amount<>0 then
            for J := RegStart to RegStart + RegCount - 1 do
              Inc(Layer[J].X,Amount);
        end;

        //Advance regionstart to first node after this region
        //This line must be executed, Continue cannot be used in the code above
        Inc(RegStart,RegCount)
      end; //Regions
    end; //Layers

    //Stop if no more improvment
    if Z>=OldZ then
      Break;
    OldZ := Z;

  until (BailOut=MaxIter) or (Z=0);

end;


procedure TSugiyamaLayout.PositioningPhase;
begin
  SetYPositions;
  SetXPositions;
end;


//Insert dummy-nodes so that each edge has length 1.
procedure TSugiyamaLayout.MakeProper;
{
  O         O
  |   -->   |
  |         x
  |         |
  O         O
}
const
  DummyWidth = 200;
var
  I,J,K,Diff : integer;
  Node : TNode;
  Edge : TEdge;

  Path : array of TNode;

  function InMakeDummy : TNode;
  begin
    Result := TNode.Create;
    Result.IsDummy := True;
    //Dummys must have a width, otherwise they will be kicked away by PositionX
    Result.W := DummyWidth;
    Result.Id := Nodes.Count;
    Nodes.Add(Result);
  end;

begin
  for I := 0 to Nodes.Count-1 do
  begin
    Node := Nodes[I];
    for J := 0 to Node.OutEdges.Count-1 do
    begin
      Edge := Node.OutEdges[J];
      Diff := Edge.ToNode.Rank - Node.Rank;
      Assert(Diff>0);
      if Diff>1 then
      begin
        //Edge spans more than one layer, create dummy nodes
        SetLength(Path,Diff-1);
        for K := 0 to High(Path) do
        begin
          Path[K] := InMakeDummy;
          Path[K].Rank := Node.Rank + K + 1;
          if K>0 then
            AddEdge(Path[K-1],Path[K]);
        end;
        for K := 0 to Edge.ToNode.InEdges.Count-1 do
          if Edge.ToNode.InEdges[K].FromNode=Node then
          begin
            Edge.ToNode.InEdges[K].FromNode := Path[High(Path)];
            Break;
          end;
        Path[High(Path)].OutEdges.Add( TEdge.Create(Path[High(Path)],Edge.ToNode) );
        Edge.ToNode := Path[0];
        Path[0].InEdges.Add( TEdge.Create(Node,Path[0]) );
      end;
    end;
  end;
end;



function WeightSortProc(Item1, Item2: Pointer): Integer;
begin
  if TNode(Item1).Weight < TNode(Item2).Weight then
    Result := -1
  else if TNode(Item1).Weight = TNode(Item2).Weight then
    Result:=0  //equal
  else
    Result := 1;
end;

function OrderSortProc(Item1, Item2: Pointer): Integer;
begin
  if TNode(Item1).Order < TNode(Item2).Order then
    Result := -1
  else if TNode(Item1).Order = TNode(Item2).Order then
    Result:=0  //equal
  else
    Result := 1;
end;

procedure TSugiyamaLayout.OrderingPhase;
const
  MaxIter = 20;
var
  I,J,BailOut,BestC : integer;
  BestO : array of integer;
  Layer : TNodeList;
  Node : TNode;

  function WeightPred(const Node : TNode) : single;
  var
    Sum,I : integer;
  begin
    Sum := 0;
    for I := 0 to Node.InEdges.Count-1 do
      Inc(Sum,Node.InEdges[I].FromNode.Order);
    if Node.InEdges.Count = 0 then
      Result := 0
    else
      Result := Sum / Node.InEdges.Count;
  end;

  function WeightSucc(const Node : TNode) : single;
  var
    Sum,I : integer;
  begin
    Sum := 0;
    for I := 0 to Node.OutEdges.Count-1 do
      Inc(Sum,Node.OutEdges[I].ToNode.Order);
    if Node.OutEdges.Count = 0 then
      Result := 0
    else
      Result := Sum / Node.OutEdges.Count;
  end;

  procedure InCheckCrossings;
  var
    I : integer;
  begin
    I := CalcCrossings;
    if I<BestC then
    begin
      BestC := I;
      for I := 0 to Nodes.Count-1 do
        BestO[I]:=Nodes[I].Order;
    end;
  end;

begin
  //**ge initial order, anropa remakeLayers;
  //**nu uppdaterar vi bara order
  for I := 0 to Layers.Count-1 do
    for J := 0 to Layers[I].Count-1 do
      Layers[I][J].Order := J;

  BailOut := 0;
  BestC := High(Integer);
  SetLength(BestO,Nodes.Count);
  repeat
    Inc(BailOut);
    //Go down and sort each layer based on the order of nodes in the layer above.
    for I := 1 to Layers.Count-1 do
    begin
      Layer := Layers[I];
      for J := 0 to Layer.Count-1 do
      begin
        Node := Layer[J];
        Node.Weight := WeightPred(Node);
      end;
      Layer.Sort( WeightSortProc );
      //Update order because nodes have switched positions
      for J := 0 to Layer.Count-1 do Layer[J].Order := J;
    end;
    InCheckCrossings;
    if BestC=0 then
      Break;
    //Go up and sort each layer based on the order of nodes in the layer below.
    for I := Layers.Count-2 downto 0 do
    begin
      Layer := Layers[I];
      for J := 0 to Layer.Count-1 do
      begin
        Node := Layer[J];
        Node.Weight := WeightSucc(Node);
      end;
      Layer.Sort( WeightSortProc );
      //Update order because nodes have switched positions
      for J := 0 to Layer.Count-1 do Layer[J].Order := J;
    end;
    InCheckCrossings;
    //**ha flera tester f鰎 n鋜 vi skall avbryta, t.ex. ingen improvment sker
    //**nu k鰎s alltid till maxiter
  until (BailOut>MaxIter) or (BestC=0);

  //Apply the best order found
  for I := 0 to Nodes.Count-1 do
    Nodes[I].Order := BestO[I];
  for I := 0 to Layers.Count-1 do
    Layers[I].Sort( OrderSortProc );
end;


function TSugiyamaLayout.CalcCrossings: integer;
var
  I : integer;
begin
  Result := 0;
  if Layers.Count>1 then
    for I := 0 to Layers.Count-2 do
      Inc( Result , CalcCrossingsTwoLayers(Layers[I],Layers[I+1]) );
end;


function ToNodeCOrderSortProc(Item1, Item2: Pointer): Integer;
begin
  if TEdge(Item1).ToNode.COrder < TEdge(Item2).ToNode.COrder then
    Result := -1
  else if TEdge(Item1).ToNode.COrder = TEdge(Item2).ToNode.COrder then
    Result:=0  //equal
  else
    Result := 1;
end;

function FromNodeCOrderSortProc(Item1, Item2: Pointer): Integer;
begin
  if TEdge(Item1).FromNode.COrder < TEdge(Item2).FromNode.COrder then
    Result := -1
  else if TEdge(Item1).FromNode.COrder = TEdge(Item2).FromNode.COrder then
    Result:=0  //equal
  else
    Result := 1;
end;

function TSugiyamaLayout.CalcCrossingsTwoLayers(const Layer1, Layer2: TNodeList): integer;
var
  COrder,I,J,K : integer;
  K1,K2,K3 : integer;
  CNodes,UL,LL : TNodeList;
  Node : TNode;
begin
  Result := 0;
  COrder:=0;
  CNodes := TNodeList.Create(False);
  UL := TNodeList.Create(False);
  LL := TNodeList.Create(False);

  //Initialize CNodes and Node.COrder
  for I :=0 to Max(Layer1.Count,Layer2.Count)-1 do
  begin
    Node:=nil;
    if I<Layer2.Count then
    begin
      Node := Layer2[I];
      Node.COrder:=COrder;
    end;
    CNodes.Add(Node);
    Inc(COrder);

    Node:=nil;
    if I<Layer1.Count then
    begin
      Node := Layer1[I];
      Node.COrder:=COrder;
    end;
    CNodes.Add(Node);
    Inc(COrder)
  end;

  {foreach cnodes, node
    if odd, sort outedges on tonode.corder
    if even, sort inedges on fromnode.corder}
  for I := 0 to CNodes.Count-1 do
  begin
    Node := CNodes[I];
    if Node=nil then
      Continue;
    if Odd(I) then
      Node.OutEdges.Sort( ToNodeCOrderSortProc )
    else
      Node.InEdges.Sort( FromNodeCOrderSortProc )
  end;

  for I := 0 to CNodes.Count-1 do
  begin
    Node := CNodes[I];
    if Node=nil then
      Continue;
    if Odd(I) then
    begin
      //Odd, upper layer
      K := UL.LastIndexOf(Node);
      if K<>-1 then
      begin
        K1:=0; K2:=0; K3:=0;
        for J := 0 to K do
        begin
          //Loop all active endpoints in upperlayer
          if UL[J]=Node then
          begin
            Inc(K1);
            Inc(K3,K2);
            UL.Items[J]:=nil;
          end
          else
            Inc(K2);
        end;
        UL.Pack;
        //Increase nr of crossings
        Inc(Result, K1 * LL.Count + K3);
      end;
      //Add new active endpoints in lowerlayer
      for J := 0 to Node.OutEdges.Count-1 do
      begin
        //Only add edges that points "to the right" (higher corder), the other edges are handled by even
        if I < Node.OutEdges[J].ToNode.COrder then
          LL.Add( Node.OutEdges[J].ToNode );
      end;
    end
    else
    begin
      //Even, lower layer
      K := LL.LastIndexOf(Node);
      if K<>-1 then
      begin
        K1:=0; K2:=0; K3:=0;
        for J := 0 to K do
        begin
          //Loop all active endpoints in upperlayer
          if LL[J]=Node then
          begin
            Inc(K1);
            Inc(K3,K2);
            LL.Items[J]:=nil;
          end
          else
            Inc(K2);
        end;
        LL.Pack;
        //Increase nr of crossings
        Inc(Result, K1 * UL.Count + K3);
      end;
      //Add new active endpoints in upperlayer
      for J := 0 to Node.InEdges.Count-1 do
      begin
        //Only add edges that points "to the right" (higher corder), the other edges are handled by odd
        if I < Node.InEdges[J].FromNode.COrder then
          UL.Add( Node.InEdges[J].FromNode );
      end;
    end;
  end;

  CNodes.Free;
  UL.Free;
  LL.Free;
end;




{ TEdge }

constructor TEdge.Create(const FromNode, ToNode: TNode);
begin
  Self.FromNode := FromNode;
  Self.ToNode := ToNode;
end;

{ TNode }

constructor TNode.Create;
begin
  InEdges := TEdgeList.Create;
  OutEdges := TEdgeList.Create;
end;

destructor TNode.Destroy;
begin
  InEdges.Free;
  OutEdges.Free;
  inherited;
end;

{ TNodeList }

function TNodeList.GetNode(Index: Integer): TNode;
begin
  Result := TNode(Get(Index));
end;

function TNodeList.LastIndexOf(const P: pointer): integer;
var
  I : integer;
begin
  Result := -1;
  for I := Count-1 downto 0 do
    if Get(I)=P then
    begin
      Result := I;
      Break;
    end;
end;

{ TEdgeList }

function TEdgeList.GetEdge(Index: Integer): TEdge;
begin
  Result := TEdge(Get(Index));
end;

{ TLayerList }

function TLayerList.GetLayer(Index: Integer): TNodeList;
begin
  Result := TNodeList(Get(Index));
end;

end.