Return to Revisions

I implement one by myself.

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


UndirectedKCycles[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],
   
   _, (* 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}]
    ]
   ]
  ]

I have verified the Mathematica code with these following test cases.

n = 5;
g = CompleteGraph[n]
UndirectedKCycles[g, #] & /@ Range[1, n, 1]

(* https://oeis.org/A284947 *)

n = 3;
g = CompleteGraph[{n,n}]
UndirectedKCycles[g, #] & /@ Range[1, 2*n, 1]

n = 3;
g = CompleteGraph[{n, n, n}]
UndirectedKCycles[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[g, #] & /@ Range[1, 10 , 1]

But the code fails for these test cases.

Can you correct the code? Any help would be appreciated.

n = 2;
g = GridGraph[{n, n, n}]
UndirectedKCycles[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[g, #] & /@ Range[1, n^2, 1]

Length /@ FindCycle[g, Infinity, All] // Tally
HighlightGraph[g, #]& /@ FindCycle[g, Infinity, All]

n = 7;
g = WheelGraph[n]
UndirectedKCycles[g, #] & /@ Range[1, n, 1]

Length /@ FindCycle[g, Infinity, All] // Tally
HighlightGraph[g, #] & /@ FindCycle[g, Infinity, All]