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