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 ;-)