Mathematica 9 is now available
Services & Resources / Wolfram Forums
-----
 /
MathGroup Archive
2004
*January
*February
*March
*April
*May
*June
*July
*August
*September
*October
*November
*December
*Archive Index
*Ask about this page
*Print this page
*Give us feedback
*Sign up for the Wolfram Insider

MathGroup Archive 2004

[Date Index] [Thread Index] [Author Index]

Search the Archive

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*"];
 
succ[adj_, n_Integer] := Flatten[Position[adj[[n]], 1]];
 
findc[adj_, start_Integer] := Union[(findc[adj, {start, #1}] & ) /@
    succ[adj, start]];
 
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]];
    If[Length[p] > Length[adj], {},
      Sequence @@ Union[(findc[adj, {a, b, y, z, #1}] & ) /@
        Complement[succ[adj, z], {b, y}]]]];
           (* 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 *)

FindAllCycles[g_Graph] := With[{adj = First[g]},
   cleanup[(findc[adj, #1] & ) /@ Range[Length[adj]]]]

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