VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsVColorBTw"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
 
' Optimised Carraghan, R., Pardalos, P. M.
' by using a heuristic vertex colouring and a backtrack search
 
Private moClasses() As Long, mnClassesCount As Long
Private level_nodes() As Long, nStart() As Long, NodesNum() As Long ' number of nodes on level
Private t As Long, mnMaxClique As Long
Private nLevelWAcc() As Long
Private nLevelDegree() As Long
Private nMaxCliques() As Long
'
 
Public Function Start() As Long
  Dim i As Long, t_minus_1 As Long, nn As Long, wt As Long
  
  ReDim level_nodes(1 To Nodes, 1 To Nodes, 0 To 1)
  ReDim nMaxCliques(1 To Nodes)
  '''''' each level has its own set of nodes
  For i = 1 To Nodes
    level_nodes(1, i, 0) = i
  Next
  '''''''''''''''''''''''''''''''''''
  DefineClasses
  ResortByWeights
  For i = 1 To Nodes
    level_nodes(1, i, 1) = i
  Next
  ReDim NodesNum(1 To mnClassesCount)
  ReDim nStart(1 To mnClassesCount)
  ReDim nLevelDegree(1 To mnClassesCount)
  ReDim nLevelWAcc(1 To mnClassesCount)
  NodesNum(1) = Nodes
  
  For nn = Nodes To 1 Step -1
    t = 2
    NodesNum(t) = 0
    nLevelWAcc(t) = w(level_nodes(1, nn, 0))
    For i = nn + 1 To Nodes
      If arr(level_nodes(1, nn, 0), level_nodes(1, i, 0)) Then
        NodesNum(t) = NodesNum(t) + 1
        level_nodes(t, NodesNum(t), 0) = level_nodes(1, i, 0)
        level_nodes(t, NodesNum(t), 1) = level_nodes(1, i, 1)
      End If
    Next
    If NodesNum(t) = 0 Then
      t = t - 1
      If nLevelWAcc(t + 1) > mnMaxClique Then
        mnMaxClique = nLevelWAcc(t + 1)
      End If
    Else
      nStart(t) = 0
    End If
    
    While t >= 2
      nStart(t) = nStart(t) + 1
            
      If NodesNum(t) < nStart(t) Then
        t = t - 1
      Else
        If (nLevelWAcc(t) + nMaxCliques(level_nodes(t, nStart(t), 1))) > _
           mnMaxClique Then
      
          If nStart(t) > 1 Then
            If (moClasses(level_nodes(t, nStart(t), 0)) <> _
                            moClasses(level_nodes(t, nStart(t) - 1, 0))) Then
                 nLevelDegree(t) = nLevelDegree(t) - w(level_nodes(t, nStart(t) - 1, 0))
            Else
                 nLevelDegree(t) = nLevelDegree(t) - (w(level_nodes(t, nStart(t) - 1, 0)) _
                     + w(level_nodes(t, nStart(t), 0)))
            End If
          Else
            ''' calculate degree on new depth
            nLevelDegree(t) = LevelDegree()
          End If
        
          If (nLevelWAcc(t) + nLevelDegree(t)) > mnMaxClique Then
            t_minus_1 = t
            t = t + 1
            nStart(t) = 0
            NodesNum(t) = 0
            nLevelWAcc(t) = nLevelWAcc(t_minus_1) + _
                    w(level_nodes(t_minus_1, nStart(t_minus_1), 0))
            ''' define nodes for the next level
            For i = nStart(t_minus_1) + 1 To NodesNum(t_minus_1)
              If arr(level_nodes(t_minus_1, nStart(t_minus_1), 0), _
                     level_nodes(t_minus_1, i, 0)) Then
                NodesNum(t) = NodesNum(t) + 1
                level_nodes(t, NodesNum(t), 0) = level_nodes(t_minus_1, i, 0)
                level_nodes(t, NodesNum(t), 1) = level_nodes(t_minus_1, i, 1)
              End If
            Next
            If NodesNum(t) = 0 Then
              t = t - 1
              If nLevelWAcc(t + 1) > mnMaxClique Then
                mnMaxClique = nLevelWAcc(t + 1)
              End If
            End If
          Else
            t = t - 1
          End If
        Else
          t = t - 1
        End If
      End If
    Wend
    nMaxCliques(nn) = mnMaxClique
  Next
  
  ''' return size of maximu clique
  Start = mnMaxClique
End Function
 
Private Sub DefineClasses()
  Dim class_init() As Boolean '' show if node exists
  Dim i As Long, k As Long
  Dim mnRemainNodes As Long, bFirstNode As Boolean, nkNode As Long
  Dim nNodeNum As Long
 
  mnClassesCount = 0
  ReDim class_init(1 To Nodes)
  ''' get info about existing nodes
  ReDim moClasses(1 To Nodes)
  '''''
  mnRemainNodes = Nodes
  While True
    ''' build up new class
    mnClassesCount = mnClassesCount + 1
    bFirstNode = True
    ''' position of first node
    i = mnRemainNodes
    While i > 0
      ''' swap nodes
      nNodeNum = level_nodes(1, i, 0)
      If i <> mnRemainNodes Then
        ''' swap rows
        level_nodes(1, i, 0) = level_nodes(1, mnRemainNodes, 0)
        level_nodes(1, mnRemainNodes, 0) = nNodeNum
      End If
      '''
      moClasses(nNodeNum) = mnClassesCount
      
      mnRemainNodes = mnRemainNodes - 1
      If mnRemainNodes = 0 Then Exit Sub
      If bFirstNode Then
        For k = 1 To mnRemainNodes
          nkNode = level_nodes(1, k, 0)
          class_init(nkNode) = arr(nNodeNum, nkNode)
        Next
      Else
        For k = 1 To mnRemainNodes
          nkNode = level_nodes(1, k, 0)
          class_init(nkNode) = arr(nNodeNum, nkNode) Or class_init(nkNode)
        Next
      End If
      bFirstNode = False
      For i = mnRemainNodes To 1 Step -1
        If Not class_init(level_nodes(1, i, 0)) Then Exit For
      Next
    Wend
  Wend
End Sub
 
Private Function LevelDegree() As Long
  Dim res As Long, i As Long, nClass As Long, aClass As Long
  
    For i = NodesNum(t) To nStart(t) Step -1
      ''' for node on level define class (moClasses) and mark it as existing
      nClass = moClasses(level_nodes(t, i, 0))
      If nClass <> aClass Then
        res = res + w(level_nodes(t, i, 0))
        aClass = nClass
      End If
    Next
 
  LevelDegree = res
 
End Function
 
Public Sub ResortByWeights()
  Dim i As Long, j As Long, maxi As Long, maxw As Long, aClass As Long
  Dim nNode As Long
  For i = Nodes To 2 Step -1
    maxi = i
    nNode = level_nodes(1, maxi, 0)
    maxw = w(nNode)
    aClass = moClasses(nNode)
    For j = i - 1 To 1 Step -1
      nNode = level_nodes(1, j, 0)
      If moClasses(nNode) <> aClass Then Exit For
      If maxw < w(nNode) Then
        maxi = j
        maxw = w(nNode)
      End If
    Next
    If i <> maxi Then
      nNode = level_nodes(1, i, 0)
      level_nodes(1, i, 0) = level_nodes(1, maxi, 0)
      level_nodes(1, maxi, 0) = nNode
    End If
  Next
End Sub