VBCommons/utility/CDS_Graph.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "CDS_Graph"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
' ====== Class Module for Graph management ========
' Shared module version: 20210419
' Tested in: TestCommons
' Depends on: ex_Collection, CDS_Edge, CDS_Node
' Required reference: Scripting
' Warning: node data should be basic type and be convertible to String (VBA.CStr)
Option Explicit

Public nodes_ As Scripting.Dictionary
Public edges_ As Scripting.Dictionary

Private Sub Class_Initialize()
  Call Clear
End Sub

Public Function Clear()
  Set nodes_ = New Scripting.Dictionary
  Set edges_ = New Scripting.Dictionary
End Function

Public Property Get Size() As Long
  Size = nodes_.Count
End Property

Public Property Get Nodes() As Collection
  Set Nodes = New Collection
  Dim vData As Variant
  For Each vData In nodes_
    Call Nodes.Add(vData)
  Next vData
End Property

Public Function AddNode(vNode As Variant)
  Call InternalAddNode(vNode)
End Function

Public Function HasNode(vNode As Variant) As Boolean
  HasNode = nodes_.Exists(vNode)
End Function

Public Function AddEdge(vSource As Variant, vDestination As Variant) As CDS_Edge
  Call AddNode(vSource)
  Call AddNode(vDestination)
  
  Dim newEdge As New CDS_Edge: Call newEdge.Init(vSource, vDestination)
  Dim sEdge$: sEdge = newEdge.ID
  
  If edges_.Exists(sEdge) Then _
    Exit Function

  Call edges_.Add(sEdge, newEdge)
  Call nodes_(vSource).outputs_.Add(vDestination)
  Call nodes_(vDestination).inputs_.Add(vSource)
  
  Set AddEdge = newEdge
End Function

Public Function HasEdge(vSource As Variant, vDestination As Variant) As Boolean
  Dim newEdge As New CDS_Edge: Call newEdge.Init(vSource, vDestination)
  Dim sEdge$: sEdge = newEdge.ID
  HasEdge = edges_.Exists(sEdge)
End Function

Public Function ExpandOutputs(ByRef target As Scripting.Dictionary)
  Dim nCount&
  Do While True
    nCount = target.Count
    Call ExpandOutsOnce(target)
    If nCount = target.Count Then _
      Exit Function
  Loop
End Function

Public Function ExpandInputs(ByRef target As Scripting.Dictionary)
  Dim nCount&
  Do While True
    nCount = target.Count
    Call ExpandInsOnce(target)
    If nCount = target.Count Then _
      Exit Function
  Loop
End Function

Public Function ExpandBiderctional(ByRef target As Scripting.Dictionary)
  Dim nCount&
  Do While True
    nCount = target.Count
    Call ExpandBiderctionalOnce(target)
    If nCount = target.Count Then _
      Exit Function
  Loop
End Function

Public Function ExpandOutsOnce(ByRef target As Scripting.Dictionary)
  Dim nCount&: nCount = target.Count
  Dim aKey As Variant
  Dim vChild As Variant
  For Each aKey In target
    For Each vChild In nodes_(aKey).outputs_
      If Not target.Exists(vChild) Then _
        Call target.Add(vChild, 0)
    Next vChild
    nCount = nCount - 1
    If nCount = 0 Then _
      Exit Function
  Next aKey
End Function

Public Function ExpandInsOnce(ByRef target As Scripting.Dictionary)
  Dim nCount&: nCount = target.Count
  Dim aKey As Variant
  Dim vChild As Variant
  For Each aKey In target
    For Each vChild In nodes_(aKey).inputs_
      If Not target.Exists(vChild) Then _
        Call target.Add(vChild, 0)
    Next vChild
    nCount = nCount - 1
    If nCount = 0 Then _
      Exit Function
  Next aKey
End Function

Public Function ExpandBiderctionalOnce(ByRef target As Scripting.Dictionary, Optional nStart& = 1)
  Dim nCount&: nCount = target.Count
  Dim aKey As Variant
  Dim vChild As Variant
  For Each aKey In target
    For Each vChild In nodes_(aKey).inputs_
      If Not target.Exists(vChild) Then _
        Call target.Add(vChild, 0)
    Next vChild
    For Each vChild In nodes_(aKey).outputs_
      If Not target.Exists(vChild) Then _
        Call target.Add(vChild, 0)
    Next vChild
    nCount = nCount - 1
    If nCount = 0 Then _
      Exit Function
  Next aKey
End Function

Public Function FilterInternalEdges(iNodes As Scripting.Dictionary) As Collection
  Dim iEdges As New Collection
  Dim anEdge As CDS_Edge
  Dim aKey As Variant
  For Each aKey In edges_
    Set anEdge = edges_(aKey)
    If iNodes.Exists(anEdge.source_) And iNodes.Exists(anEdge.dest_) Then _
      Call iEdges.Add(anEdge)
  Next aKey
  Set FilterInternalEdges = iEdges
End Function

' ==============
Private Function InternalAddNode(vNode As Variant)
  If nodes_.Exists(vNode) Then _
    Exit Function

  Dim newNode As New CDS_Node
  newNode.data_ = vNode
  Call nodes_.Add(vNode, newNode)
End Function