VBCommons/utility/API_GraphOrdering.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "API_GraphOrdering"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
' ======= Graph sorting and ordering facilities =====
' Shared module version: 20210422
' Tested in: TestCommons
' Depends on: ex_Collection, CDS_Graph, API_LinkedComponents
' Required reference: Scripting
Option Explicit
 
Private graph_ As CDS_Graph
Private nodes_ As Collection
Private sourceOrder_ As Scripting.Dictionary ' Map of (nodeID, globalIndex)
Private nodeComponents_ As Scripting.Dictionary ' Map of (nodeID, componentIndex)
Private componentCount_ As Long

Private status_ As Scripting.Dictionary
Private ranks_ As Scripting.Dictionary

Private Const MAX_NODE_INDEX& = 100000
Private Const RANK_UNDEF = -1

Private Enum TVisitStatus
  T_STATUS_UNVISITED = 0
  T_STATUS_VISITING = 1
  T_STATUS_VISITED = 2
End Enum

Public Function Init(iGraph As CDS_Graph)
  Call SetGraph(iGraph)
End Function

' Classic topological order (no edges pointing backward in order)
Public Function TopologicalOrder() As Collection
  Set sourceOrder_ = Nothing
  Set TopologicalOrder = RevertCollection(DefaultOrder)
End Function

' Reversed topological order
Public Function ReverseTopologicalOrder() As Collection
  Set sourceOrder_ = Nothing
  Set ReverseTopologicalOrder = DefaultOrder
End Function

' Topological order where linked components are grouped together
Public Function TopologicalComponentOrder() As Collection
  Set sourceOrder_ = Nothing
  Dim iOrder As Collection: Set iOrder = RevertCollection(DefaultOrder)
  Set TopologicalComponentOrder = GroupNodesDefault(iOrder)
End Function

' Reversed topological order where linked components are grouped together
Public Function ReverseTopologicalComponentOrder() As Collection
  Set sourceOrder_ = Nothing
  Dim iOrder As Collection: Set iOrder = DefaultOrder
  Set ReverseTopologicalComponentOrder = GroupNodesDefault(iOrder)
End Function

' Sort topologically using BFS and ordering according to input
' Note: elements not present in the graph are excluded from output
Public Function SortLayers(iSourceOrder As Collection) As Collection
  If iSourceOrder.Count = 0 Then
    Set SortLayers = New Collection
    Exit Function
  End If
  
  Call InitSourceOrder(iSourceOrder)
  Dim iNodesOrder As Collection: Set iNodesOrder = InduceWidthOrder
  Dim iComponents As Collection: Set iComponents = SortComponents(iNodesOrder)
  Set SortLayers = GroupNodesInduced(iNodesOrder, iComponents)
End Function

' Sort topologically using DFS and ordering according to input
' Note: elements not present in the graph are excluded from output
Public Function SortDeep(iSourceOrder As Collection) As Collection
  If iSourceOrder.Count = 0 Then
    Set SortDeep = New Collection
    Exit Function
  End If
  
  Call InitSourceOrder(iSourceOrder)
  Dim iNodesOrder As Collection: Set iNodesOrder = InduceDepthOrder
  Dim iComponents As Collection: Set iComponents = SortComponents(iNodesOrder)
  Set SortDeep = GroupNodesInduced(iNodesOrder, iComponents)
End Function

' ==============
Private Function SetGraph(iGraph As CDS_Graph)
  Set graph_ = iGraph
  Set nodes_ = graph_.Nodes
  Dim iProcessor As New API_LinkedComponents
  Set nodeComponents_ = iProcessor.GetComponents(graph_)
  componentCount_ = iProcessor.CountComponents
End Function

Private Function DefaultOrder()
  Dim iOrder As New Collection
  
  Call InitStatus
  
  Dim iStack As Collection
  Dim vNode As Variant
  For Each vNode In nodes_
    If status_(vNode) <> T_STATUS_UNVISITED Then _
      GoTo NEXT_NODE
    Set iStack = New Collection: Call iStack.Add(vNode)
    Do While iStack.Count > 0
      Dim vItem As Variant: vItem = iStack.Item(iStack.Count)
      If status_(vItem) = T_STATUS_UNVISITED Then
        status_(vItem) = T_STATUS_VISITING
        Dim vChild As Variant
        For Each vChild In graph_.nodes_(vItem).outputs_
          If status_(vChild) = T_STATUS_UNVISITED Then _
            Call iStack.Add(vChild)
        Next vChild
      Else
        Call iStack.Remove(iStack.Count)
        If status_(vItem) <> T_STATUS_VISITED Then
          status_(vItem) = T_STATUS_VISITED
          Call iOrder.Add(vItem)
        End If
      End If
    Loop
NEXT_NODE:
  Next vNode
  
  Set DefaultOrder = iOrder
End Function

Private Function InduceWidthOrder() As Collection
  Dim iOrder As New Collection
  
  Call InitRanks
  
  Dim iQueue As Collection: Set iQueue = New Collection
  Dim iKnown As New Scripting.Dictionary
  Dim vNode As Variant
  For Each vNode In CompleteInducedOrder
    If ranks_(vNode) = 1 Then
      Call iQueue.Add(vNode)
      Call iKnown.Add(vNode, 0)
    End If
  Next vNode
    
  Do While iQueue.Count > 0
    vNode = iQueue.Item(1)
    Call iQueue.Remove(1)
    Call iOrder.Add(vNode)
    
    If graph_.nodes_(vNode).outputs_.Count > 0 Then
      Dim vChildren() As Variant: vChildren = ToArray(graph_.nodes_(vNode).outputs_)
      Call SortChildren(vChildren)
      Dim vChild As Variant
      For Each vChild In vChildren
        If Not iKnown.Exists(vChild) Then
          If ranks_(vChild) = ranks_(vNode) + 1 Then
            Call iQueue.Add(vChild)
            Call iKnown.Add(vChild, 0)
          End If
        End If
      Next vChild
    End If
  Loop

  Set InduceWidthOrder = iOrder
End Function

Private Function InduceDepthOrder() As Collection
  Dim iOrder As New Collection
  
  Call InitRanks

  Dim iStack As Collection: Set iStack = New Collection
  Dim iKnown As New Scripting.Dictionary
  Dim vNode As Variant
  For Each vNode In RevertCollection(CompleteInducedOrder)
    If ranks_(vNode) = 1 Then
      Call iStack.Add(vNode)
    End If
  Next vNode
  
  Dim vChildren() As Variant
  Dim vChild As Variant
  Dim nChild&
  Do While iStack.Count > 0
    vNode = iStack.Item(iStack.Count)
    Call iStack.Remove(iStack.Count)
    If iKnown.Exists(vNode) Then _
      GoTo NEXT_ITEM
      
    Call iOrder.Add(vNode)
    Call iKnown.Add(vNode, 0)

    If graph_.nodes_(vNode).outputs_.Count > 0 Then
      vChildren = ToArray(graph_.nodes_(vNode).outputs_)
      Call SortChildren(vChildren)
      For nChild = UBound(vChildren) To LBound(vChildren) Step -1
        vChild = vChildren(nChild)
        If Not iKnown.Exists(vChild) Then _
          Call iStack.Add(vChild)
      Next nChild
    End If
NEXT_ITEM:
  Loop

  Set InduceDepthOrder = iOrder
End Function

Private Function InitStatus()
  Set status_ = New Scripting.Dictionary
  Dim vNode As Variant
  For Each vNode In nodes_
    status_(vNode) = T_STATUS_UNVISITED
  Next vNode
End Function

Private Function InitRanks()
  Call InitStatus

  Set ranks_ = New Scripting.Dictionary
  Dim vNode As Variant
  For Each vNode In CompleteInducedOrder
    ranks_(vNode) = RANK_UNDEF
  Next vNode
  
  For Each vNode In nodes_
    Call PropagateRank(vNode, 1)
  Next vNode
End Function

Private Function PropagateRank(vNode As Variant, nRank&)
  If ranks_(vNode) >= nRank Then _
    Exit Function
  ranks_(vNode) = nRank
  
  If graph_.nodes_(vNode).outputs_.Count = 0 Then _
    Exit Function
  
  status_(vNode) = T_STATUS_VISITING
  
  Dim vChildren() As Variant: vChildren = ToArray(graph_.nodes_(vNode).outputs_)
  Call SortChildren(vChildren)
  Dim vChild As Variant
  For Each vChild In vChildren
    If status_(vChild) <> T_STATUS_VISITING Then _
      Call PropagateRank(vChild, nRank + 1)
  Next vChild
  
  status_(vNode) = T_STATUS_VISITED
End Function

Private Function InitSourceOrder(iSourceOrder As Collection)
  Set sourceOrder_ = New Scripting.Dictionary
  Dim aVal As Variant
  Dim nIndex&: nIndex = 1
  For Each aVal In iSourceOrder
    If graph_.HasNode(aVal) Then
      sourceOrder_(aVal) = nIndex
      nIndex = nIndex + 1
    End If
  Next aVal
End Function

Private Function CompleteInducedOrder() As Collection
  Dim iOrder As New Collection
  Dim vItem As Variant
  For Each vItem In sourceOrder_
    Call iOrder.Add(vItem)
  Next vItem
  
  If iOrder.Count = graph_.Size Then
    Set CompleteInducedOrder = iOrder
    Exit Function
  End If
  
  For Each vItem In nodes_
    If Not sourceOrder_.Exists(vItem) Then _
      Call iOrder.Add(vItem)
  Next vItem
  
  Set CompleteInducedOrder = iOrder
End Function

Private Function SortChildren(ByRef target() As Variant)
  If UBound(target) < 1 Then _
    Exit Function
  Dim i&, j&
  Dim vItem As Variant
  For i = LBound(target) + 1 To UBound(target) Step 1
    vItem = target(i)
    Dim nIndex&: nIndex = GetNodeIndex(vItem)
    j = i - 1
    Do While j >= 0
      If GetNodeIndex(target(j)) <= nIndex Then _
        Exit Do
      target(j + 1) = target(j)
      j = j - 1
    Loop
    target(j + 1) = vItem
  Next i
End Function

Private Function GroupNodesDefault(iNodes As Collection) As Collection
  Dim iResult As New Collection
  Dim nComponent&
  For nComponent = 0 To componentCount_ - 1 Step 1
    Dim vNode As Variant
    For Each vNode In iNodes
      If Not sourceOrder_ Is Nothing Then _
        If Not sourceOrder_.Exists(vNode) Then _
          GoTo NEXT_NODE
      If nodeComponents_(vNode) = nComponent Then _
        Call iResult.Add(vNode)
NEXT_NODE:
    Next vNode
  Next nComponent
  Set GroupNodesDefault = iResult
End Function

Private Function GetNodeIndex(vNode As Variant) As Long
  If sourceOrder_.Exists(vNode) Then
    GetNodeIndex = sourceOrder_(vNode)
  Else
    GetNodeIndex = MAX_NODE_INDEX
  End If
End Function

Private Function SortComponents(iNodesOrder As Collection) As Collection
  Dim iOrder As New Collection
  Dim nComponent&
  Dim vNode As Variant
  For Each vNode In iNodesOrder
    nComponent = nodeComponents_(vNode)
    Call SafeAddToCollection(nComponent, VBA.CStr(nComponent), iOrder)
  Next vNode
  Set SortComponents = iOrder
End Function

Private Function GroupNodesInduced(iNodes As Collection, iComponents As Collection) As Collection
  Dim iResult As New Collection
  Dim nComponent As Variant
  For Each nComponent In iComponents
    Dim vNode As Variant
    For Each vNode In iNodes
      If Not sourceOrder_.Exists(vNode) Then _
        GoTo NEXT_NODE
      If nodeComponents_(vNode) = nComponent Then _
        Call iResult.Add(vNode)
NEXT_NODE:
    Next vNode
  Next nComponent
  Set GroupNodesInduced = iResult
End Function