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