topologicalsort.pas

unit topologicalsort;
{ Dependency checker/topological sort

  Copyright (C) 2010-2014 Reinier Olislagers

  This library is free software; you can redistribute it and/or modify it
  under the terms of the GNU Library General Public License as published by
  the Free Software Foundation; either version 2 of the License, or (at your
  option) any later version.

  This program is distributed in the hope that it will be useful, but WITHOUT
  ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
  for more details.

  You should have received a copy of the GNU Library General Public License
  along with this library; if not, write to the Free Software Foundation,
  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
}

{$mode objfpc}{$H+}
//{$DEFINE TOPODEBUG} //if you want to see loads of diagnostic info

interface

uses
  Classes, SysUtils;

type
  RNodeIndex = record
    NodeName: String; //Name of the node
    //Index: integer; //Index number used in DepGraph. For now, we can distill the index from the array index. If we want to use a TList or similar, we'd need an index property
    Order: integer;  //Order when sorted
  end;

  RDepGraph = record
    Node: integer;  //Refers to Index in NodeIndex
    DependsOn: integer; //The Node depends on this other Node.
  end;

  { TTopologicalSort }
  TTopologicalSort = class(TObject)
  private
    Nodes: array of RNodeIndex;
    DependencyGraph: array of RDepGraph;
    FCanBeSorted: boolean;
    function SearchNode(NodeName: String): integer;
    function SearchIndex(NodeID: integer): String;
    function DepFromNodeID(NodeID: integer): integer;
    function DepFromDepID(DepID: integer): integer;
    function DepFromNodeIDDepID(NodeID, DepID: integer): integer;
    procedure DelDependency(const Index: integer);
  public
    constructor Create;
    destructor Destroy; override;
    procedure Sort(const UnorderedInput: TStringList; var SortedOutput: TStringList); //Directly sort input into output
    procedure Sort(var SortedOutput: TStringList); //Sort nodes into output
    procedure AddNode(NodeName: String); // Add an item to the input
    procedure AddDependency(NodeName, DependsOn: String); //Add a dependency to another item on the input
    procedure AddNodeDependencies(NodeAndDependencies: TStringList); // Each string has node, and the nodes it depends on. This allows insertion of an entire dependency graph at once
    //procedure DelNode(NodeName: String);
    procedure DelDependency(NodeName, DependsOn: String);

    property CanBeSorted: boolean read FCanBeSorted;

  end;

implementation

const
  INVALID = -1;
// index not found for index search functions, no sort order defined, or record invalid/deleted

function TTopologicalSort.SearchNode(NodeName: String): integer;
var
  Counter: integer;
begin
  // Return -1 if node not found. If node found, return index in array
  Result := INVALID;
  for Counter := 0 to High(Nodes) do
  begin
    if Nodes[Counter].NodeName = NodeName then
    begin
      Result := Counter;
      break;
    end;
  end;
end;

function TTopologicalSort.SearchIndex(NodeID: integer): String;
  // Look up name for the index
begin
  if (NodeID > 0) and (NodeID <= High(Nodes)) then
  begin
    Result := Nodes[NodeID].NodeName;
  end
  else
  begin
    Result := 'ERROR'; //something's fishy, this shouldn't happen
  end;
end;

function TTopologicalSort.DepFromNodeID(NodeID: integer): integer;
  // Look for Node index number in the dependency graph
  // and return the first node found. If nothing found, return -1
var
  Counter: integer;
begin
  Result := INVALID;
  for Counter := 0 to High(DependencyGraph) do
  begin
    if DependencyGraph[Counter].Node = NodeID then
    begin
      Result := Counter;
      break;
    end;
  end;
end;

function TTopologicalSort.DepFromDepID(DepID: integer): integer;
  // Look for dependency index number in the dependency graph
  // and return the index for the first one found. If nothing found, return -1
var
  Counter: integer;
begin
  Result := INVALID;
  for Counter := 0 to High(DependencyGraph) do
  begin
    if DependencyGraph[Counter].DependsOn = DepID then
    begin
      Result := Counter;
      break;
    end;
  end;
end;

function TTopologicalSort.DepFromNodeIDDepID(NodeID, DepID: integer): integer;
  // Shows index for the dependency from NodeID on DepID, or INVALID if not found
var
  Counter: integer;
begin
  Result := INVALID;
  for Counter := 0 to High(DependencyGraph) do
  begin
    if DependencyGraph[Counter].Node = NodeID then
      if DependencyGraph[Counter].DependsOn = DepID then
      begin
        Result := Counter;
        break;
      end;
  end;
end;

procedure TTopologicalSort.DelDependency(const Index: integer);
// Removes dependency from array.
// Is fastest when the dependency is near the top of the array
// as we're copying the remaining elements.
var
  Counter: integer;
  OriginalLength: integer;
begin
  OriginalLength := Length(DependencyGraph);
  if Index = OriginalLength - 1 then
  begin
    SetLength(DependencyGraph, OriginalLength - 1);
  end;
  if Index < OriginalLength - 1 then
  begin
    for Counter := Index to OriginalLength - 2 do
    begin
      DependencyGraph[Counter] := DependencyGraph[Counter + 1];
    end;
    SetLength(DependencyGraph, OriginalLength - 1);
  end;
  if Index > OriginalLength - 1 then
  begin
    // This could happen when deleting on an empty array:
    raise Exception.Create('Tried to delete index ' + IntToStr(Index) +
      ' while the maximum index was ' + IntToStr(OriginalLength - 1));
  end;
end;

constructor TTopologicalSort.Create;
begin
  inherited Create;
end;

destructor TTopologicalSort.Destroy;
begin
  // Clear up data just to make sure:
  Finalize(DependencyGraph);
  Finalize(Nodes);
  inherited;
end;

procedure TTopologicalSort.Sort(const UnorderedInput: TStringList; var SortedOutput: TStringList);
begin
  AddNodeDependencies(UnorderedInput);
  Sort(SortedOutput);
end;

procedure TTopologicalSort.Sort(var SortedOutput: TStringList);
var
  {$IFDEF TOPODEBUG}
  DebugCounter: integer;
  {$ENDIF}
  Counter: integer;
  NodeCounter: integer;
  OutputSortOrder: integer;
  DidSomething: boolean; //used to detect cycles (circular references)
  Node: integer;
begin
  OutputSortOrder := 0;
  DidSomething := True; // prime the loop below
  FCanBeSorted := True; //hope for the best.
  {$IFDEF TOPODEBUG}
  Sortedoutput.Add('debug: nodes before processing: ');
  for DebugCounter := 0 to High(Nodes) do
  begin
    SortedOutput.Add('debug: node ' + IntToStr(DebugCounter) + ' has name:' +
      Nodes[DebugCounter].Nodename + ' - sort order: ' +
      IntToStr(Nodes[DebugCounter].Order));
  end;
  SortedOutput.add('debug: dependencies before processing: ');
  for DebugCounter := 0 to High(DependencyGraph) do
  begin
    SortedOutput.Add(
      'debug: dep #' + IntToStr(DebugCounter) + ': ' +
      Nodes[DependencyGraph[DebugCounter].Node].NodeName + '(' +
      IntToStr(DependencyGraph[DebugCounter].Node) + ') depends on: ' +
      Nodes[DependencyGraph[DebugCounter].DependsOn].NodeName + '(' +
      IntToStr(DependencyGraph[DebugCounter].DependsOn) + ')'
      );
  end;
  {$ENDIF}
  while (DidSomething = True) do
  begin
    // 1. Find all nodes (now) without dependencies, output them first and remove the dependencies:
    // 1.1 Nodes that are not present in the dependency graph at all:
    {$IFDEF TOPODEBUG}
    SortedOutput.Add('debug: 1.1 only in node list. begin. outputsortorder = ' +
      IntToStr(OutputSortOrder));
    {$ENDIF}
    for Counter := 0 to High(Nodes) do
    begin
      if DepFromNodeID(Counter) = INVALID then
      begin
        if DepFromDepID(Counter) = INVALID then
        begin
          // Node doesn't occur in either side of the dependency graph, so it has sort order 0:
          DidSomething := True;
          {$IFDEF TOPODEBUG}
          SortedOutput.Add('debug: 1.1 found counter: ' + IntToStr(Counter) +
            ', nodename:' + Nodes[Counter].NodeName);
          {$ENDIF}
          if (Nodes[Counter].Order = INVALID) or
            (Nodes[Counter].Order > OutputSortOrder) then
          begin
            // Enter sort order if the node doesn't have a lower valid order already.
            Nodes[Counter].Order := OutputSortOrder;
          end;
        end; //Invalid Dep
      end; //Invalid Node
    end; //Count

    // Done with the first batch, so we can increase the sort order:
    OutputSortOrder := OutputSortOrder + 1;
    {$IFDEF TOPODEBUG}
    SortedOutput.Add('debug: 1.1 only in node list. end. outputsortorder = ' +
      IntToStr(OutputSortOrder));
    {$ENDIF}
    // 1.2 Nodes that are only present on the right hand side of the dep graph:
    {$IFDEF TOPODEBUG}
    SortedOutput.Add('debug: 1.2 only on right hand side. begin for SortOrder: ' +
      IntToStr(OutputSortOrder) + ' - high(DepGraph):' +
      IntToStr(High(DependencyGraph)));
    {$ENDIF}
    DidSomething := False;
    // reverse order so we can delete dependencies without passing upper array
    for Counter := High(DependencyGraph) downto 0 do
    begin
      Node := DependencyGraph[Counter].DependsOn; //the depended node
      if (DepFromNodeID(Node) = INVALID) then
      begin
        DidSomething := True;
        //Delete dependency so we don't hit it again:
        {$IFDEF TOPODEBUG}
        SortedOutput.Add('debug: going to delete dependency ' + IntToStr(Counter) +
          ' from: *' + Nodes[DependencyGraph[Counter].Node].NodeName +
          '* on: *' + Nodes[DependencyGraph[Counter].DependsOn].NodeName + '*.');
        {$ENDIF}
        DelDependency(Counter);
        if (Nodes[Node].Order = INVALID) or (Nodes[Node].Order > OutputSortOrder) then
        begin
          // Enter sort order if the node doesn't have a lower valid order already.
          Nodes[Node].Order := OutputSortOrder;
          {$IFDEF TOPODEBUG}
          SortedOutput.add('debug: current order for node ' + Nodes[Node].NodeName +
            ' changed to: ' + IntToStr(Nodes[Node].Order));
          {$ENDIF}
        end;
      end;
      OutputSortOrder := OutputSortOrder + 1; //next iteration
    end;
    // 2. Go back to 1 until we can't do more work, and do some bookkeeping:
    OutputSortOrder := OutputSortOrder + 1;
  end; //outer loop for 1 to 2
  OutputSortOrder := OutputSortOrder - 1; //fix unused last loop.

  {$IFDEF TOPODEBUG}
  SortedOutput.add('debug: nodes after end of processing: ');
  for DebugCounter := 0 to High(Nodes) do
  begin
    SortedOutput.Add('debug: node ' + IntToStr(DebugCounter) + ' has name:' +
      Nodes[DebugCounter].Nodename + ' - sort order: ' +
      IntToStr(Nodes[DebugCounter].Order));
  end;
  // Output all dependencies:
  SortedOutput.add('debug: dependencies after processing: ');
  for DebugCounter := 0 to High(DependencyGraph) do
  begin
    SortedOutput.Add(
      'debug: dep #' + IntToStr(DebugCounter) + ': ' +
      Nodes[DependencyGraph[DebugCounter].Node].NodeName + '(' +
      IntToStr(DependencyGraph[DebugCounter].Node) + ') depends on: ' +
      Nodes[DependencyGraph[DebugCounter].DependsOn].NodeName + '(' +
      IntToStr(DependencyGraph[DebugCounter].DependsOn) + ')'
      );
  end;
  {$ENDIF}
  // 2. If we have dependencies left, we have a cycle; exit.
  if (High(DependencyGraph) > 0) then
  begin
    FCanBeSorted := False; //indicate we have a cycle
    SortedOutput.Add('Cycle (circular dependency) detected, cannot sort further. Dependencies left:');
    for Counter := 0 to High(DependencyGraph) do
    begin
      SortedOutput.Add(SearchIndex(DependencyGraph[Counter].Node) +
        ' depends on: ' + SearchIndex(DependencyGraph[Counter].DependsOn));
    end;
  end
  else
  begin
    // No cycle:
    // Now parse results, if we have them
    for Counter := 0 to OutputSortOrder do
    begin
      for NodeCounter := 0 to High(Nodes) do
      begin
        if Nodes[NodeCounter].Order = Counter then
        begin
          SortedOutput.Add(Nodes[NodeCounter].NodeName
          {$IFDEF TOPODEBUG}
            + ' (' + IntToStr(Nodes[NodeCounter].Order) + ')'
          {$ENDIF}
            );
        end;
      end; //output each result
    end; //order iteration
  end; //cycle detection
end;

procedure TTopologicalSort.AddNode(NodeName: String);
var
  NodesNewLength: integer;
begin
  // Adds node; make sure we don't add duplicate entries
  if SearchNode(NodeName) = INVALID then
  begin
    NodesNewLength := Length(Nodes) + 1;
    SetLength(Nodes, NodesNewLength);
    Nodes[NodesNewLength - 1].NodeName := NodeName; //Arrays are 0 based
    //Nodes[NodesNewLength -1].Index :=  //If we change the object to a tlist or something, we already have an index property
    Nodes[NodesNewLength - 1].Order := INVALID; //default value
  end;
end;

procedure TTopologicalSort.AddDependency(NodeName, DependsOn: String);
begin
  // Make sure both nodes in the dependency exist as a node
  if SearchNode(NodeName) = INVALID then
  begin
    Self.AddNode(NodeName);
  end;
  if SearchNode(DependsOn) = INVALID then
  begin
    Self.AddNode(DependsOn);
  end;
  // Add the dependency, only if we don't depend on ourselves:
  if NodeName <> DependsOn then
  begin
    SetLength(DependencyGraph, Length(DependencyGraph) + 1);
    DependencyGraph[High(DependencyGraph)].Node := SearchNode(NodeName);
    DependencyGraph[High(DependencyGraph)].DependsOn := SearchNode(DependsOn);
  end;
end;

procedure TTopologicalSort.AddNodeDependencies(NodeAndDependencies: TStringList);
// Takes a stringlist containing a list of strings. Each string contains node names
// separated by spaces. The first node depends on the others. It is permissible to have
// only one node name, which doesn't depend on anything.
// This procedure will add the dependencies and the nodes in one go.
var
  Deplist: TStringList;
  StringCounter: integer;
  NodeCounter: integer;
begin
  if Assigned(NodeAndDependencies) then
  begin
    DepList := TStringList.Create;
    try
      for StringCounter := 0 to NodeAndDependencies.Count - 1 do
      begin
        // For each string in the argument: split into names, and process:
        DepList.Delimiter := ' '; //use space to separate the entries
        DepList.StrictDelimiter := False; //allows us to ignore double spaces in input.
        DepList.DelimitedText := NodeAndDependencies[StringCounter];
        for NodeCounter := 0 to DepList.Count - 1 do
        begin
          if NodeCounter = 0 then
          begin
            // Add the first node, which might be the only one.
            Self.AddNode(Deplist[0]);
          end;

          if NodeCounter > 0 then
          begin
            // Only add dependency from the second item onwards
            // The AddDependency code will automatically add Deplist[0] to the Nodes, if required
            Self.AddDependency(DepList[0], DepList[NodeCounter]);
          end;
        end;
      end;
    finally
      DepList.Free;
    end;
  end;
end;

procedure TTopologicalSort.DelDependency(NodeName, DependsOn: String);
// Delete the record.
var
  NodeID: integer;
  DependsID: integer;
  Dependency: integer;
begin
  NodeID := Self.SearchNode(NodeName);
  DependsID := Self.SearchNode(DependsOn);
  if (NodeID <> INVALID) and (DependsID <> INVALID) then
  begin
    // Look up dependency and delete it.
    Dependency := Self.DepFromNodeIDDepID(NodeID, DependsID);
    if (Dependency <> INVALID) then
    begin
      Self.DelDependency(Dependency);
    end;
  end;
end;

end.