Re: Finding all cycles in a graph

• To: mathgroup at smc.vnet.net
• Subject: [mg47329] Re: Finding all cycles in a graph
• From: "Peter Pein" <petsie at arcor.de>
• Date: Mon, 5 Apr 2004 05:23:17 -0400 (EDT)
• References: <c4jack\$dlk\$1@smc.vnet.net>
• Sender: owner-wri-mathgroup at wolfram.com

```"Anupama Shivaprasad" <anupama at docomolabs-usa.com> schrieb im Newsbeitrag
news:c4jack\$dlk\$1 at smc.vnet.net...
>
> Hi all,
>
> I am trying to find the cycles in a graph, more speifically a complete
> graph. The function FindCycle, available in the Discrete Math package
> finds one cycle that is present in the graph and the function
> ExtractCycles, extracts a cycle, deletes that cycle and trys to find
> more cycles in the deleted cycle graph.
>
> I was wondering if there was some routine that somone here happened to
> have that could compute and display all the cycles in an undirected
> complete graph. For Example, if I had a complete graph of 4 vertices,
> then the cycles for the same would be:
>
> {1,2,4,1}
> {1,3,4,1}
> {1,2,3,1}
> {2,3,4,2}
> {1,2,3,4,1}
>
> Thanks,
> Anu
>
Hi Anu,
I don't know anything about theory of graphs and I do not understand, why
{1,2,3,4,1} is the only cycle of length 4, because {1, 2, 4, 3, 1} and {1,
3, 2, 4, 1} look different to me. It seems that order doesn't matter:

<< "Discretemath`Combinatorica`"
Clear[findc, succ, "cleanup*"];

findc[adj_, {y_, z_}] := Sequence @@ Union[(findc[adj, {y, z, #1}] & ) /@
Complement[succ[adj, z], {y}]]; (* avoid going back *)

findc[adj_, {a_, b___, y_, z_}] := Module[{p = {a, b, y, z}},
If[a == z, Return[p]];
Sequence @@ Union[(findc[adj, {a, b, y, z, #1}] & ) /@
(* avoid going back and "shortcuts" *)

cleanup1[cycles_] := (* delete double cycles (orderless) *)
Module[{cy = ({#1, Union[#1]} & ) /@ Union @@ cycles, i, n},
For[i = 1, i < (n = Length[cy]), i++, cy = Join[cy[[Range[i]]],
DeleteCases[cy[[Range[i + 1, n]]], {_, cy[[i,2]]}]]]; First /@ cy];

cleanup2[cycles_] := (* delete double cycles (order matters) *)
Module[{cl = cycles, i, j, tmp, k},
For[i = 1, i < Length[cl], i++,
For[j = 1, j < Length[cl[[i]]], j++,
cl[[i]] = DeleteCases[cl[[i]], Reverse[cl[[i,j]]]]];
For[j =Length[cl[[i]]], j > 0, j--,
tmp = cl[[i,j]];
Do[{k, tmp} = tmp /. {a_, b_, c___, a_} ->
{b, {b, c, a, b}}; (* rotate left, keep syntax *)
If[k > i,
cl[[k]] = DeleteCases[cl[[k]], tmp | Reverse[tmp]]],
{Length[tmp] - 1}]]];
Union @@ cl];

cleanup = cleanup1; (* choose one *)

In[12]:= ac4 = FindAllCycles[CompleteGraph[4]]
Out[12]= {{1, 2, 3, 1}, {1, 2, 4, 1}, {1, 3, 4, 1}, {2, 3, 4, 2},
{1, 2, 3, 4, 1}}
In[13]:= (Timing[Length[FindAllCycles[CompleteGraph[#1]]]] & ) /@ Range[3,
7]
Out[13]= {{0.01 Second, 1}, {0.07 Second, 5}, {0.301 Second, 16},
{2.303 Second, 42}, {23.934 Second, 99}}

There's a lot to optimize, I fear :-\

Hope, this is an usable starting point,
Peter

--
Peter Pein, Berlin
for not being filtered, start the subject with [
...and don't mention viagara-falls ;-)

```

• Prev by Date: bug in Random
• Next by Date: RE: Defining anti-symmetric operation. New ideas requested.
• Previous by thread: Finding all cycles in a graph
• Next by thread: Re: Abs function & question about version 5