VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsOptimisedVCBT"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

' Optimised Carraghan, R., Pardalos, P. M. algorithm
' by using a heuristic vertex colouring classes for pruning' and a backtrack search by
' colour classes

Private moClasses() As Long, mnClassesCount As Long
Private nLevelDegree() As Long
Private level_nodes() As Long, nStart() As Long, NodesNum() As Long
Private t As Long, mnMaxClique As Long
Private nMaxCliques() As Long
'

Public Function Start() As Long
  Dim i As Long, t_minus_1 As Long, nn As Long
  
  ReDim level_nodes(0 To Nodes, 1 To Nodes)

  mnMaxClique = 0
  '''''' each level has its own set of nodes
  For i = 1 To Nodes
    level_nodes(0, i) = i
  Next
  
  '''''
  DefineClasses
  
  ReDim NodesNum(0 To mnClassesCount + 1)
  ReDim nStart(1 To mnClassesCount + 1)
  ReDim nLevelDegree(1 To mnClassesCount + 1)
  ReDim nMaxCliques(1 To Nodes)

  NodesNum(1) = 0
  
  For nn = 1 To mnClassesCount
    t = 1
    nStart(1) = 0
    For i = Nodes To 1 Step -1
      If moClasses(level_nodes(0, i)) <= nn Then
        nStart(1) = nStart(1) + 1
        level_nodes(1, nStart(1)) = level_nodes(0, i)
      Else
        Exit For
      End If
    Next
    NodesNum(1) = nStart(1)
    nMaxCliques(nn) = Nodes
    
    While t >= 1
      
      ''' Degree control
      If NodesNum(t) < 1 Then
        t = t - 1
        NodesNum(t) = NodesNum(t) - 1
      Else
        ''' if it is not first node (for fist node degree can not be adjusted)
        ''' and prev. node class is not the same then decrease degree (can do since vertices are sorted
        ''' and if cur. vertex class is not the same as for previous then prev class is not any longer existing)
        If nStart(t) > NodesNum(t) Then
          If (moClasses(level_nodes(t, NodesNum(t))) <> moClasses(level_nodes(t, NodesNum(t) + 1))) Then
            nLevelDegree(t) = nLevelDegree(t) - 1
          End If
        Else
          ''' calculate degree on new depth
          nLevelDegree(t) = LevelDegree()
        End If
        
        If ((t - 1 + nLevelDegree(t)) <= mnMaxClique) Or _
          ((t - 1 + nMaxCliques(moClasses(level_nodes(t, NodesNum(t))))) <= mnMaxClique) Then
          t = t - 1
          NodesNum(t) = NodesNum(t) - 1
        Else
          t_minus_1 = t
          t = t + 1
          NodesNum(t) = 0
          ''' define nodes for the next level
          For i = 1 To NodesNum(t_minus_1) - 1
            If arr(level_nodes(t_minus_1, NodesNum(t_minus_1)), level_nodes(t_minus_1, i)) Then
              NodesNum(t) = NodesNum(t) + 1
              level_nodes(t, NodesNum(t)) = level_nodes(t_minus_1, i)
            End If
          Next
          nStart(t) = NodesNum(t)
          If NodesNum(t) = 0 Then
            t = t - 1
            NodesNum(t) = NodesNum(t) - 1
            If t > mnMaxClique Then
              mnMaxClique = t
              t = 0
            End If
          End If
              
        End If
      End If
    Wend
    nMaxCliques(nn) = mnMaxClique
  Next
  
  ''' return size of maximu clique
  Start = mnMaxClique

End Function

Private Function LevelDegree() As Long
  Dim res As Long, i As Long, nClass As Long, aClass As Long
    
    For i = 1 To NodesNum(t)
      ''' for node on level define class (moClasses) and mark it as existing
      nClass = moClasses(level_nodes(t, i))
      If nClass <> aClass Then
        aClass = nClass
        res = res + 1
      End If
    Next
    
  LevelDegree = res
End Function

Private Sub DefineClasses()
  Dim class_init() As Boolean '' show if node exist
  Dim i As Long, k As Long
  Dim mnRemainNodes As Long, bFirstNode As Boolean, nkNode As Long, 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(0, i)
      If i <> mnRemainNodes Then
        ''' swap rows
        level_nodes(0, i) = level_nodes(0, mnRemainNodes)
        level_nodes(0, mnRemainNodes) = 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(0, k)
          class_init(nkNode) = arr(nNodeNum, nkNode)
        Next
        bFirstNode = False
      Else
        For k = 1 To mnRemainNodes
          nkNode = level_nodes(0, k)
          class_init(nkNode) = arr(nNodeNum, nkNode) Or class_init(nkNode)
        Next
      End If
      For i = mnRemainNodes To 1 Step -1
        If Not class_init(level_nodes(0, i)) Then Exit For
      Next
    Wend
  Wend
End Sub