Clear["Global`*"];
Needs["IGraphM`"]
count1Cycles[g_Graph] :=
List @@@ EdgeList[g] // Count[#, _?(#[[1]] == #[[2]] &)] &
count2Cycles[g_Graph] :=
Map[#[[2]] &, EdgeList[g] // Tally] // Select[# >= 2 &] //
Map[Binomial[#, 2] &, #] & // Total
count3Cycles[g_Graph] := Tr[MatrixPower[AdjacencyMatrix[g], 3]]/6;
count4Cycles[g_Graph] :=
Module[{A =
AdjacencyMatrix[g]}, (Tr[MatrixPower[A, 4]] +
Tr[MatrixPower[A, 2]] - 2*Total[VertexDegree[g]^2])/8];
count5Cycles[g_Graph] :=
Module[{A = Normal@AdjacencyMatrix[g], A3, n = VertexCount[g]},
A3 = MatrixPower[A,
3]; (Tr[MatrixPower[A, 5]] - 5*Tr[MatrixPower[A, 3]] -
5*Sum[(Sum[A[[i, j]], {j, 1, n}] - 2)*A3[[i, i]], {i, 1, n}])/10]
KhomenkoandGolovkoUndirectedKCycles[g_Graph, k_Integer] :=
UndirectedKCycles[graph_Graph Module[{n, vertices, subsets, As, traceSum, i, binomialCoefficient,
sumOverI},
If[k == 1, Return[count1Cycles[g]]];
If[k == 2, Return[count2Cycles[g]]];
n = VertexCount[g];
vertices = VertexList[g];
sumOverI = 0;
For[i = 2, i <= k && i <= n, i++,
subsets = Subsets[vertices, {n - i}];
traceSum = Sum[binomialCoefficient = Binomial[n - i, n - k];
As = Normal@AdjacencyMatrix[g];
As = DeleteRowsColumns[As, SubsetToIndices[vertices, subset]];
binomialCoefficient*Tr[MatrixPower[As, k]], {subset, subsets}];
sumOverI += ((-1)^(k - i))*traceSum;];
sumOverI/(2*k)]
(*Helper function to delete rows and columns from a matrix*)
DeleteRowsColumns[matrix_, indices_] :=
Module[{tempMatrix}, tempMatrix = matrix;
(*Delete rows*)tempMatrix = Delete[tempMatrix, List /@ indices];
(*Delete columns,transpose needed for column deletion*)
tempMatrix =
Transpose[Delete[Transpose[tempMatrix], List /@ indices]];
tempMatrix];
(*Helper function to convert a subset to indices based on the full \
set*)
SubsetToIndices[fullSet_, subset_] :=
Flatten[Position[fullSet, #] & /@ subset]
GiscardetalUndirectedKCycles[graph_Graph, k_Integer] :=
Module[{H, tr, numNeighbors, adjacencyMatrix, subgraphs, vertices, n},
vertices = VertexList[graph];
n = VertexCount[graph];
adjacencyMatrix = AdjacencyMatrix[graph];
subgraphs = Select[Subsets[vertices, {1, n}], ConnectedGraphQ[Subgraph[graph, #]] &];
tr[A_, power_] := Tr[MatrixPower[A, power]];
numNeighbors[H_] := Length@Complement[vertices, VertexList[H], Flatten[VertexList /@ NeighborhoodGraph[graph, #] & /@ VertexList[H]]];
Switch[k,
1, (* If k == 1*)
count1Cycles[graph],
2, (* If k == 2*)
count2Cycles[graph],
3, (* If k == 3*)
count3Cycles[graph],
4, (* If k == 4*)
count4Cycles[graph],
5, (* If k == 5*)
count5Cycles[graph],
_, (* Otherwise, use the formula *)
Total[
((-1)^k / (2*k)) *
Table[
With[{H = Subgraph[graph, sg]},
Binomial[numNeighbors[H], k - VertexCount[H]] *
(-1)^VertexCount[H] *
tr[AdjacencyMatrix[H], k]
], {sg, subgraphs}]
]
]
]
n = 5;
g = CompleteGraph[n]
UndirectedKCycles[gGiscardetalUndirectedKCycles[g, #] & /@ Range[1, n, 1]
(* https://oeis.org/A284947 *)
n = 3;
g = CompleteGraph[{n,n}]
UndirectedKCycles[gGiscardetalUndirectedKCycles[g, #] & /@ Range[1, 2*n, 1]
n = 3;
g = CompleteGraph[{n, n, n}]
UndirectedKCycles[gGiscardetalUndirectedKCycles[g, #] & /@ Range[1, 3*n, 1]
g = Graph[{1 \[UndirectedEdge] 2, 2 \[UndirectedEdge] 2,
1 \[UndirectedEdge] 1, 1 \[UndirectedEdge] 1,
2 \[UndirectedEdge] 2, 1 \[UndirectedEdge] 2}]
UndirectedKCycles[gGiscardetalUndirectedKCycles[g, #] & /@ Range[1, 10 , 1]
n = 2;
g = GridGraph[{n, n, n}]
UndirectedKCycles[gGiscardetalUndirectedKCycles[g, #] & /@ Range[1, n^3, 1]
Length /@ FindCycle[g, Infinity, All] // Tally
HighlightGraph[g, #]& /@ FindCycle[g, Infinity, All]
n = 3;
g = GridGraph[{n, n}]
UndirectedKCycles[gGiscardetalUndirectedKCycles[g, #] & /@ Range[1, n^2, 1]
Length /@ FindCycle[g, Infinity, All] // Tally
HighlightGraph[g, #]& /@ FindCycle[g, Infinity, All]
n = 7;
g = WheelGraph[n]
UndirectedKCycles[gGiscardetalUndirectedKCycles[g, #] & /@ Range[1, n, 1]
Length /@ FindCycle[g, Infinity, All] // Tally
HighlightGraph[g, #] & /@ FindCycle[g, Infinity, All]
