[Date Index]
[Thread Index]
[Author Index]
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**
| |